.#*
*.swo
checksums.txt
+a.out
clean:
rm -f vm/*.o
- rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib}
+ rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} Factor.app/Contents/Frameworks/libfactor.dylib
vm/resources.o:
$(WINDRES) vm/factor.rs vm/resources.o
factor.com -i=boot.<cpu>.image
-Before bootstrapping, you will need to download the DLLs for the Pango
-text rendering library. The required DLLs are listed in
-build-support/dlls.txt and are available from the following location:
-
- <http://factorcode.org/dlls>
-
Once bootstrapped, double-clicking factor.exe or factor.com starts
the Factor UI.
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: functors destructors accessors kernel parser words ;
+USING: functors destructors accessors kernel parser words
+effects generalizations sequences ;
IN: alien.destructors
SLOT: alien
<F-destructor> DEFINES <${F}-destructor>
&F DEFINES &${F}
|F DEFINES |${F}
+N [ F stack-effect out>> length ]
WHERE
: <F-destructor> ( alien -- destructor ) f F-destructor boa ; inline
-M: F-destructor dispose* alien>> F ;
+M: F-destructor dispose* alien>> F N ndrop ;
: &F ( alien -- alien ) dup <F-destructor> &dispose drop ; inline
ARTICLE: "alien.fortran-abis" "Fortran ABIs"
"Fortran does not have a standard ABI like C does. Factor supports the following Fortran ABIs:"
{ $list
- { { $subsection gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
- { { $subsection f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
- { { $subsection intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
- { { $subsection intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
+ { { $link gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
+ { { $link f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
+ { { $link intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
+ { { $link intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
}
"A library's ABI is specified when that library is opened by the " { $link add-fortran-library } " word." ;
math.order sorting strings system alien.libraries ;
IN: alien.fortran
-SINGLETONS: f2c-abi gfortran-abi intel-unix-abi intel-windows-abi ;
+SINGLETONS: f2c-abi g95-abi gfortran-abi intel-unix-abi intel-windows-abi ;
<<
: add-f2c-libraries ( -- )
HOOK: fortran-c-abi fortran-abi ( -- abi )
M: f2c-abi fortran-c-abi "cdecl" ;
+M: g95-abi fortran-c-abi "cdecl" ;
M: gfortran-abi fortran-c-abi "cdecl" ;
M: intel-unix-abi fortran-c-abi "cdecl" ;
M: intel-windows-abi fortran-c-abi "cdecl" ;
HOOK: real-functions-return-double? fortran-abi ( -- ? )
M: f2c-abi real-functions-return-double? t ;
+M: g95-abi real-functions-return-double? f ;
M: gfortran-abi real-functions-return-double? f ;
M: intel-unix-abi real-functions-return-double? f ;
M: intel-windows-abi real-functions-return-double? f ;
HOOK: complex-functions-return-by-value? fortran-abi ( -- ? )
M: f2c-abi complex-functions-return-by-value? f ;
+M: g95-abi complex-functions-return-by-value? f ;
M: gfortran-abi complex-functions-return-by-value? t ;
M: intel-unix-abi complex-functions-return-by-value? f ;
M: intel-windows-abi complex-functions-return-by-value? f ;
HOOK: character(1)-maps-to-char? fortran-abi ( -- ? )
M: f2c-abi character(1)-maps-to-char? f ;
+M: g95-abi character(1)-maps-to-char? f ;
M: gfortran-abi character(1)-maps-to-char? f ;
M: intel-unix-abi character(1)-maps-to-char? t ;
M: intel-windows-abi character(1)-maps-to-char? t ;
HOOK: mangle-name fortran-abi ( name -- name' )
M: f2c-abi mangle-name lowercase-name-with-extra-underscore ;
+M: g95-abi mangle-name lowercase-name-with-extra-underscore ;
M: gfortran-abi mangle-name lowercase-name-with-underscore ;
M: intel-unix-abi mangle-name lowercase-name-with-underscore ;
M: intel-windows-abi mangle-name >upper ;
--- /dev/null
+extensions
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax io.streams.string assocs
-heaps.private ;
-IN: assoc-heaps
-
-HELP: <assoc-heap>
-{ $values { "assoc" assoc } { "heap" heap } { "assoc-heap" assoc-heap } }
-{ $description "Constructs a new " { $link assoc-heap } " from two existing data structures." } ;
-
-HELP: <unique-max-heap>
-{ $values { "unique-heap" assoc-heap } }
-{ $description "Creates a new " { $link assoc-heap } " where the assoc is a hashtable and the heap is a max-heap. Popping an element from the heap leaves this element in the hashtable to ensure that the element will not be processed again." } ;
-
-HELP: <unique-min-heap>
-{ $values { "unique-heap" assoc-heap } }
-{ $description "Creates a new " { $link assoc-heap } " where the assoc is a hashtable and the heap is a min-heap. Popping an element from the heap leaves this element in the hashtable to ensure that the element will not be processed again." } ;
-
-{ <unique-max-heap> <unique-min-heap> } related-words
-
-HELP: assoc-heap
-{ $description "A data structure containing an assoc and a heap to get certain properties with better time constraints at the expense of more space and complexity. For instance, a hashtable and a heap can be combined into one assoc-heap to get a sorted data structure with O(1) lookup. Operations on assoc-heap may update both the assoc and the heap or leave them out of sync if it's advantageous." } ;
-
-ARTICLE: "assoc-heaps" "Associative heaps"
-"The " { $vocab-link "assoc-heaps" } " vocabulary combines exists to synthesize data structures with better time properties than either of the two component data structures alone." $nl
-"Associative heap constructor:"
-{ $subsection <assoc-heap> }
-"Unique heaps:"
-{ $subsection <unique-min-heap> }
-{ $subsection <unique-max-heap> } ;
-
-ABOUT: "assoc-heaps"
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test assoc-heaps ;
-IN: assoc-heaps.tests
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs hashtables heaps kernel ;
-IN: assoc-heaps
-
-TUPLE: assoc-heap assoc heap ;
-
-C: <assoc-heap> assoc-heap
-
-: <unique-min-heap> ( -- unique-heap )
- H{ } clone <min-heap> <assoc-heap> ;
-
-: <unique-max-heap> ( -- unique-heap )
- H{ } clone <max-heap> <assoc-heap> ;
-
-M: assoc-heap heap-push* ( value key assoc-heap -- entry )
- pick over assoc>> key? [
- 3drop f
- ] [
- [ assoc>> swapd set-at ] [ heap>> heap-push* ] 3bi
- ] if ;
-
-M: assoc-heap heap-pop ( assoc-heap -- value key )
- heap>> heap-pop ;
-
-M: assoc-heap heap-peek ( assoc-heap -- value key )
- heap>> heap-peek ;
-
-M: assoc-heap heap-empty? ( assoc-heap -- value key )
- heap>> heap-empty? ;
+++ /dev/null
-Doug Coleman
\ No newline at end of file
+++ /dev/null
-Priority queue with fast insertion, removal of first element, and lookup of arbitrary elements by key
ascii encode >base64-lines >string
] unit-test
+[ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ]
+[ malformed-base64? ] must-fail-with
+
\ >base64 must-infer
\ base64> must-infer
sequences strings io.crlf ;
IN: base64
+ERROR: malformed-base64 ;
+
<PRIVATE
: read1-ignoring ( ignoring -- ch )
f 0 f f f 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
22 23 24 25 f f f f f f 26 27 28 29 30 31 32 33 34 35 36 37 38 39
40 41 42 43 44 45 46 47 48 49 50 51
- } nth ; inline
+ } nth [ malformed-base64 ] unless* ; inline
SYMBOL: column
[ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
[ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
-ERROR: malformed-base64 ;
-
: decode4 ( seq -- )
[ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
[ [ CHAR: = = ] count ] bi head-slice*
HELP: sorted-index
{ $values { "obj" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } }
-{ $description "Outputs the index and value of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
+{ $description "Outputs the index of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link index } "." } ;
{ index index-from last-index last-index-from sorted-index } related-words
[ optimized>> ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
[ ] count-words " words total" print
-
+
"Bootstrapping is complete." print
"Now, you can run Factor:" print
vm write " -i=" write "output-image" get print flush ;
+: save/restore-error ( quot -- )
+ error get-global
+ error-continuation get-global
+ [ call ] 2dip
+ error-continuation set-global
+ error set-global ; inline
+
[
! We time bootstrap
millis
drop
[
load-help? off
- "vocab:bootstrap/bootstrap-error.factor" run-file
+ [ "vocab:bootstrap/bootstrap-error.factor" parse-file ] save/restore-error
+ call
] with-scope
] recover
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.functions namespaces sequences
-strings system vocabs.loader threads accessors combinators
-locals classes.tuple math.order summary combinators.short-circuit ;
+USING: accessors arrays classes.tuple combinators combinators.short-circuit
+ kernel locals math math.functions math.order namespaces sequences strings
+ summary system threads vocabs.loader ;
IN: calendar
HOOK: gmt-offset os ( -- hours minutes seconds )
GENERIC: leap-year? ( obj -- ? )
M: integer leap-year? ( year -- ? )
- dup 100 mod zero? 400 4 ? mod zero? ;
+ dup 100 divisor? 400 4 ? divisor? ;
M: timestamp leap-year? ( timestamp -- ? )
year>> leap-year? ;
#! good for any date since October 15, 1582
[
dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
- [ dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + ] dip
+ [ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
[ 1+ 3 * 5 /i + ] keep 2 * +
] dip 1+ + 7 mod ;
ARTICLE: "colors" "Colors"
"The " { $vocab-link "colors" } " vocabulary defines a protocol for colors, with a concrete implementation for RGBA colors. This vocabulary is used by " { $vocab-link "io.styles" } ", " { $vocab-link "ui" } " and other vocabularies, but it is independent of them."
$nl
-"RGBA colors:"
+"RGBA colors with floating point components in the range " { $snippet "[0,1]" } ":"
{ $subsection rgba }
{ $subsection <rgba> }
"Converting a color to RGBA:"
--- /dev/null
+extensions
--- /dev/null
+extensions
ARTICLE: "combinators.smart" "Smart combinators"
-"The " { $vocab-link "combinators.smart" } " vocabulary implements " { $emphasis "smart combinators" } ". A smart combinator is one whose behavior depends on the static stack effect of an input quotation." $nl
-"Smart inputs from a sequence:"
+"The macros in the " { $vocab-link "combinators.smart" } " vocabulary look at the static stack effects of input quotations and generate code which produces or consumes the relevant number of stack values." $nl
+"Call a quotation and discard all output values:"
+{ $subsection drop-outputs }
+"Take all input values from a sequence:"
{ $subsection input<sequence }
-"Smart outputs to a sequence:"
+"Store all output values to a sequence:"
{ $subsection output>sequence }
{ $subsection output>array }
-"Reducing the output of a quotation:"
+"Reducing the set of output values:"
{ $subsection reduce-outputs }
-"Summing the output of a quotation:"
+"Summing output values:"
{ $subsection sum-outputs }
-"Appending the results of a quotation:"
+"Concatenating output values:"
{ $subsection append-outputs }
{ $subsection append-outputs-as } ;
stack-checker math ;
IN: combinators.smart
+MACRO: drop-outputs ( quot -- quot' )
+ dup infer out>> '[ @ _ ndrop ] ;
+
MACRO: output>sequence ( quot exemplar -- newquot )
[ dup infer out>> ] dip
'[ @ _ _ nsequence ] ;
--- /dev/null
+extensions
: default-cli-args ( -- )
global [
"quiet" off
- "script" off
"e" off
"user-init" on
embedded? "quiet" set
: interval-to-spill ( active-intervals current -- live-interval )
#! We spill the interval with the most distant use location.
start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
- unclip-slice [ [ [ second ] bi@ > ] most ] reduce first ;
+ [ ] [ [ [ second ] bi@ > ] most ] map-reduce first ;
: assign-spill ( before after -- before after )
#! If it has been spilled already, reuse spill location.
GENERIC: optimized. ( quot/word -- )
-M: method-spec optimized. first2 method optimized. ;
-
M: word optimized. specialized-def optimized. ;
M: callable optimized. build-tree optimize-tree nodes>quot . ;
: value-infos-union ( infos -- info )
[ null-info ]
- [ unclip-slice [ value-info-union ] reduce ] if-empty ;
+ [ [ ] [ value-info-union ] map-reduce ] if-empty ;
: literals<= ( info1 info2 -- ? )
{
{
{ [ 2dup interval-subset? ] [ empty-interval ] }
{ [ over empty-interval eq? ] [ empty-interval ] }
- { [ 2dup interval>= t eq? ] [ 1./0. [a,a] ] }
- { [ 2dup interval<= t eq? ] [ -1./0. [a,a] ] }
+ { [ 2dup interval>= t eq? ] [ 1/0. [a,a] ] }
+ { [ 2dup interval<= t eq? ] [ -1/0. [a,a] ] }
[ [-inf,inf] ]
} cond interval-union nip ;
]\r
] dip later ;\r
\r
+ERROR: wait-timeout ;\r
+\r
: wait ( queue timeout status -- )\r
over [\r
[ queue-timeout [ drop ] ] dip suspend\r
- [ "Timeout" throw ] [ cancel-alarm ] if\r
+ [ wait-timeout ] [ cancel-alarm ] if\r
] [\r
[ drop '[ _ push-front ] ] dip suspend drop\r
] if ;\r
IN: concurrency.mailboxes.tests\r
-USING: concurrency.mailboxes concurrency.count-downs vectors\r
-sequences threads tools.test math kernel strings namespaces\r
+USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions\r
+vectors sequences threads tools.test math kernel strings namespaces\r
continuations calendar destructors ;\r
\r
{ 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as\r
[ ] [ "d" get 5 seconds await-timeout ] unit-test\r
\r
[ ] [ "m" get dispose ] unit-test\r
+\r
+[ { "foo" "bar" } ] [\r
+ <mailbox>\r
+ "foo" over mailbox-put\r
+ "bar" over mailbox-put\r
+ mailbox-get-all\r
+] unit-test\r
+\r
+[\r
+ <mailbox> 1 seconds mailbox-get-timeout\r
+] [ wait-timeout? ] must-fail-with\r
+
\ No newline at end of file
\r
: mailbox-get-all-timeout ( mailbox timeout -- array )\r
block-if-empty\r
- [ dup mailbox-empty? ]\r
+ [ dup mailbox-empty? not ]\r
[ dup data>> pop-back ]\r
produce nip ;\r
\r
strings db.errors ;
IN: db.errors.sqlite
-ERROR: unparsed-sqlite-error error ;
+TUPLE: unparsed-sqlite-error error ;
+C: <unparsed-sqlite-error> unparsed-sqlite-error
SINGLETONS: table-exists table-missing ;
=> [[ table >string message sqlite-table-error ]]
| "no such table: " .+:table
=> [[ table >string <sql-table-missing> ]]
+ | .*:error
+ => [[ error >string <unparsed-sqlite-error> ]]
;EBNF
strings math.parser math.intervals combinators math.bitwise
nmake db db.tuples db.types classes words shuffle arrays
destructors continuations db.tuples.private prettyprint
-db.private ;
+db.private byte-arrays ;
IN: db.queries
GENERIC: where ( specs obj -- )
[ " or " 0% ] [ dupd where ] interleave drop
] in-parens ;
+M: byte-array where ( spec obj -- )
+ over column-name>> 0% " = " 0% bind# ;
+
M: NULL where ( spec obj -- )
drop column-name>> 0% " is NULL" 0% ;
T{ exam f 4 "Cartman" 41 }
}
] [
- T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples
+ T{ exam f T{ interval f { 2 t } { 1/0. f } } } select-tuples
] unit-test
[
T{ exam f 1 "Kyle" 100 }
}
] [
- T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } select-tuples
+ T{ exam f T{ interval f { -1/0. t } { 2 f } } } select-tuples
] unit-test
[
T{ exam f 4 "Cartman" 41 }
}
] [
- T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples
+ T{ exam f T{ interval f { -1/0. t } { 1/0. f } } } select-tuples
] unit-test
[
[ test-compound-primary-key ] test-sqlite
[ test-compound-primary-key ] test-postgresql
+
+
+TUPLE: example id data ;
+
+example "EXAMPLE"
+{
+ { "id" "ID" +db-assigned-id+ }
+ { "data" "DATA" BLOB }
+} define-persistent
+
+: test-blob-select ( -- )
+ example ensure-table
+ [ ] [ example new B{ 1 2 3 4 5 } >>data insert-tuple ] unit-test
+ [
+ T{ example { id 1 } { data B{ 1 2 3 4 5 } } }
+ ] [ example new B{ 1 2 3 4 5 } >>data select-tuple ] unit-test ;
+
+[ test-blob-select ] test-sqlite
+[ test-blob-select ] test-postgresql
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: delegate sequences.private sequences assocs
-io definitions kernel continuations ;
+USING: delegate sequences.private sequences assocs io ;
IN: delegate.protocols
PROTOCOL: sequence-protocol
PROTOCOL: output-stream-protocol
stream-flush stream-write1 stream-write stream-nl ;
-
-PROTOCOL: definition-protocol
-where set-where forget uses
-synopsis* definer definition ;
"A word's documentation:"
{ $code "\\ foo >link edit" }
"A method definition:"
- { $code "{ editor draw-gadget* } edit" }
+ { $code "M\\ fixnum + edit" }
"A help article:"
{ $code "\"handbook\" >link edit" }
} ;
furnace.utilities\r
furnace.redirection\r
furnace.conversations\r
+furnace.chloe-tags\r
html.forms\r
html.components\r
html.components\r
: expire-state ( class -- )
new
- -1.0/0.0 millis [a,b] >>expires
+ -1/0. millis [a,b] >>expires
delete-tuples ;
TUPLE: server-state-manager < filter-responder timeout ;
"furnace.auth.providers.db" require
"furnace.auth.providers.null" require
"furnace.boilerplate" require
-"furnace.chloe-tags" require
"furnace.conversations" require
"furnace.db" require
"furnace.json" require
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors combinators namespaces fry urls http
-http.server http.server.redirection http.server.responses
+USING: kernel accessors combinators namespaces fry urls urls.secure
+http http.server http.server.redirection http.server.responses
http.server.remapping http.server.filters furnace.utilities ;
IN: furnace.redirection
}
{ $references
{ "Since quotations are objects, they can be constructed and taken apart at will. You can write code that writes code. Arrays are just one of the various types of sequences, and the sequence operations such as " { $link each } " and " { $link map } " operate on all types of sequences. There are many more sequence iteration operations than the ones above, too." }
- "dataflow"
+ "combinators"
"sequences"
} ;
io.streams.byte-array classes.builtin parser lexer
classes.predicate classes.union classes.intersection
classes.singleton classes.tuple help.vocabs math.parser
-accessors ;
+accessors definitions ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
{ "associative mapping" { "an object whose class implements the " { $link "assocs-protocol" } } }
{ "boolean" { { $link t } " or " { $link f } } }
{ "class" { "a set of objects identified by a " { $emphasis "class word" } " together with a discriminating predicate. See " { $link "classes" } } }
- { "definition specifier" { "a " { $link word } ", " { $link method-spec } ", " { $link link } ", vocabulary specifier, or any other object whose class implements the " { $link "definition-protocol" } } }
+ { "combinator" { "a word taking a quotation or another word as input; a higher-order function. See " { $link "combinators" } } }
+ { "definition specifier" { "an instance of " { $link definition } " which implements the " { $link "definition-protocol" } } }
{ "generalized boolean" { "an object interpreted as a boolean; a value of " { $link f } " denotes false and anything else denotes true" } }
{ "generic word" { "a word whose behavior depends can be specialized on the class of one of its inputs. See " { $link "generic" } } }
{ "method" { "a specialized behavior of a generic word on a class. See " { $link "generic" } } }
{ "object" { "any datum which can be identified" } }
{ "ordering specifier" { "see " { $link "order-specifiers" } } }
{ "pathname string" { "an OS-specific pathname which identifies a file" } }
+ { "quotation" { "an anonymous function; an instance of the " { $link quotation } " class. More generally, instances of the " { $link callable } " class can be used in many places documented to expect quotations" } }
{ "sequence" { "a sequence; see " { $link "sequence-protocol" } } }
{ "slot" { "a component of an object which can store a value" } }
{ "stack effect" { "a pictorial representation of a word's inputs and outputs, for example " { $snippet "+ ( x y -- z )" } ". See " { $link "effects" } } }
$nl
"Tail-call optimization allows iterative algorithms to be implemented in an efficient manner using recursion, without the need for any kind of primitive looping construct in the language. However, in practice, most iteration is performed via combinators such as " { $link while } ", " { $link each } ", " { $link map } ", " { $link assoc-each } ", and so on. The definitions of these combinators do bottom-out in recursive words, however." ;
-ARTICLE: "evaluator" "Evaluation semantics"
+ARTICLE: "evaluator" "Stack machine model"
{ $link "quotations" } " are evaluated sequentially from beginning to end. When the end is reached, the quotation returns to its caller. As each object in the quotation is evaluated in turn, an action is taken based on its type:"
{ $list
{ "a " { $link word } " - the word's definition quotation is called. See " { $link "words" } }
"An " { $emphasis "object" } " is any datum which may be identified. All values are objects in Factor. Each object carries type information, and types are checked at runtime; Factor is dynamically typed."
{ $subsection "equality" }
{ $subsection "math.order" }
-{ $subsection "destructors" }
{ $subsection "classes" }
{ $subsection "tuples" }
{ $subsection "generic" }
-{ $subsection "slots" }
-{ $subsection "mirrors" } ;
+"Advanced features:"
+{ $subsection "delegate" }
+{ $subsection "mirrors" }
+{ $subsection "slots" } ;
ARTICLE: "numbers" "Numbers"
{ $subsection "arithmetic" }
"Fixed-length sequences:"
{ $subsection "arrays" }
{ $subsection "quotations" }
-"Fixed-length specialized sequences:"
{ $subsection "strings" }
{ $subsection "byte-arrays" }
+{ $subsection "specialized-arrays" }
"Resizable sequences:"
{ $subsection "vectors" }
{ $subsection "byte-vectors" }
{ $subsection "growable" }
{ $heading "Associative mappings" }
{ $subsection "assocs" }
-{ $subsection "namespaces" }
+{ $subsection "linked-assocs" }
+{ $subsection "biassocs" }
{ $subsection "refs" }
"Implementations:"
{ $subsection "hashtables" }
{ $subsection "dlists" }
{ $subsection "search-deques" }
{ $heading "Other collections" }
-{ $subsection "boxes" }
+{ $subsection "lists" }
+{ $subsection "disjoint-sets" }
+{ $subsection "interval-maps" }
{ $subsection "heaps" }
+{ $subsection "boxes" }
{ $subsection "graphs" }
{ $subsection "buffers" }
"There are also many other vocabularies tagged " { $link T{ vocab-tag { name "collections" } } } " in the library." ;
-USING: io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ;
+USING: io.encodings.utf8 io.encodings.binary io.files ;
ARTICLE: "encodings-introduction" "An introduction to encodings"
"In order to express text in terms of binary, some sort of encoding has to be used. In a modern context, this is understood as a two-way mapping between Unicode code points (characters) and some amount of binary. Since English isn't the only language in the world, ASCII is not sufficient as a mapping from binary to Unicode; it can't even express em-dashes or curly quotes. Unicode was designed as a universal character set that could potentially represent everything." $nl
"Not all encodings can represent all Unicode code points, but Unicode can represent basically everything that exists in modern encodings. Some encodings are language-specific, and some can represent everything in Unicode. Though the world is moving toward Unicode and UTF-8, the reality today is that there are several encodings which must be taken into account." $nl
-"Factor uses a system of encoding descriptors to denote encodings. Encoding descriptors are objects which describe encodings. Examples are " { $link utf8 } ", " { $link ascii } " and " { $link binary } ". Encoding descriptors can be passed around independently. Each encoding descriptor has some method for constructing an encoded or decoded stream, and the resulting stream has an encoding descriptor stored which has methods for reading or writing characters." $nl
+"Factor uses a system of encoding descriptors to denote encodings. Encoding descriptors are objects which describe encodings. Examples are " { $link utf8 } " and " { $link binary } ". Encoding descriptors can be passed around independently. Each encoding descriptor has some method for constructing an encoded or decoded stream, and the resulting stream has an encoding descriptor stored which has methods for reading or writing characters." $nl
"Constructors for streams which deal with bytes usually take an encoding as an explicit parameter. For example, to open a text file for reading whose contents are in UTF-8, use the following"
{ $code "\"file.txt\" utf8 <file-reader>" }
"If there is an error in the encoded stream, a replacement character (0xFFFD) will be inserted. To throw an exception upon error, use a strict encoding as follows"
{ $code "\"file.txt\" utf8 strict <file-reader>" }
"In a similar way, encodings can be specified when opening a file for writing."
-{ $code "\"file.txt\" ascii <file-writer>" }
+{ $code "USE: io.encodings.ascii" "\"file.txt\" ascii <file-writer>" }
"An encoding is also needed for some words that don't return streams, such as " { $link file-contents } ", for example"
-{ $code "\"file.txt\" utf16 file-contents" }
+{ $code "USE: io.encodings.utf16" "\"file.txt\" utf16 file-contents" }
"Encoding descriptors are also used by " { $link "io.streams.byte-array" } " and taken by combinators like " { $link with-file-writer } " and " { $link with-byte-reader } " which deal with streams. It is " { $emphasis "not" } " used with " { $link "io.streams.string" } " because these deal with abstract text."
$nl
"When the " { $link binary } " encoding is used, a " { $link byte-array } " is expected for writing and returned for reading, since the stream deals with bytes. All other encodings deal with strings, since they are used to represent text." ;
{ $heading "Predicate classes" }
{ $index [ classes [ predicate-class? ] filter ] } ;
-ARTICLE: "program-org" "Program organization"
-{ $subsection "definitions" }
-{ $subsection "vocabularies" }
-{ $subsection "parser" }
-{ $subsection "vocabs.loader" }
-{ $subsection "source-files" } ;
-
USING: help.cookbook help.tutorial ;
ARTICLE: "handbook-language-reference" "Language reference"
+"Fundamentals:"
{ $subsection "conventions" }
{ $subsection "syntax" }
-{ $subsection "dataflow" }
-{ $subsection "objects" }
-{ $subsection "program-org" }
+{ $subsection "effects" }
+"Data types:"
+{ $subsection "booleans" }
{ $subsection "numbers" }
{ $subsection "collections" }
-{ $subsection "io" }
+"Evaluation semantics:"
+{ $subsection "evaluator" }
+{ $subsection "words" }
+{ $subsection "shuffle-words" }
+{ $subsection "combinators" }
+{ $subsection "errors" }
+{ $subsection "continuations" }
+"Named values:"
+{ $subsection "locals" }
+{ $subsection "namespaces" }
+{ $subsection "namespaces-global" }
+{ $subsection "values" }
+"Abstractions:"
+{ $subsection "objects" }
+{ $subsection "destructors" }
+{ $subsection "macros" }
+{ $subsection "fry" }
+"Program organization:"
+{ $subsection "vocabs.loader" }
"Vocabularies tagged " { $link T{ vocab-tag { name "extensions" } } } " implement various additional language abstractions." ;
ARTICLE: "handbook-environment-reference" "Environment reference"
+"Parse time and compile time:"
+{ $subsection "parser" }
+{ $subsection "definitions" }
+{ $subsection "vocabularies" }
+{ $subsection "source-files" }
+{ $subsection "compiler" }
+"Tools:"
{ $subsection "prettyprint" }
{ $subsection "tools" }
-{ $subsection "cli" }
-{ $subsection "rc-files" }
{ $subsection "help" }
{ $subsection "inference" }
-{ $subsection "compiler" }
-{ $subsection "system" }
{ $subsection "images" }
-{ $subsection "alien" }
+"VM:"
+{ $subsection "cli" }
+{ $subsection "rc-files" }
{ $subsection "init" }
-{ $subsection "layouts" }
-{ $see-also "program-org" } ;
+{ $subsection "system" }
+{ $subsection "layouts" } ;
ARTICLE: "handbook-library-reference" "Library reference"
"This index only includes articles from loaded vocabularies. To explore more vocabularies, see " { $link "vocab-index" } "."
"Learn the language:"
{ $subsection "cookbook" }
{ $subsection "first-program" }
+"Reference material:"
{ $subsection "handbook-language-reference" }
{ $subsection "handbook-environment-reference" }
+{ $subsection "io" }
{ $subsection "ui" }
+{ $subsection "ui-tools" }
+{ $subsection "unicode" }
+{ $subsection "alien" }
{ $subsection "handbook-library-reference" }
"Explore loaded libraries:"
{ $subsection "article-index" }
{ $link "handbook" }
{ $link "vocab-index" }
{ $link "ui-tools" }
- { $link "handbook-library-reference" }
}
{ $heading "Recently visited" }
{ $table
M: object add-recent-where f ;
: $recent ( element -- )
- first get [ nl ] [ 1array $pretty-link ] interleave ;
+ first get reverse [ nl ] [ 1array $pretty-link ] interleave ;
: $recent-searches ( element -- )
drop recent-searches get [ <$link> ] map $list ;
io.files io.files.temp io.directories html.streams help kernel
assocs sequences make words accessors arrays help.topics vocabs
tools.vocabs help.vocabs namespaces prettyprint io
-vocabs.loader serialize fry memoize unicode.case math.order
-sorting debugger html xml.syntax xml.writer ;
+vocabs.loader serialize fry memoize ascii unicode.case math.order
+sorting debugger html xml.syntax xml.writer math.parser ;
IN: help.html
: escape-char ( ch -- )
- dup H{
- { CHAR: " "__quo__" }
- { CHAR: * "__star__" }
- { CHAR: : "__colon__" }
- { CHAR: < "__lt__" }
- { CHAR: > "__gt__" }
- { CHAR: ? "__que__" }
- { CHAR: \\ "__back__" }
- { CHAR: | "__pipe__" }
- { CHAR: / "__slash__" }
- { CHAR: , "__comma__" }
- { CHAR: @ "__at__" }
- } at [ % ] [ , ] ?if ;
+ dup ascii? [
+ dup H{
+ { CHAR: " "__quo__" }
+ { CHAR: * "__star__" }
+ { CHAR: : "__colon__" }
+ { CHAR: < "__lt__" }
+ { CHAR: > "__gt__" }
+ { CHAR: ? "__que__" }
+ { CHAR: \\ "__back__" }
+ { CHAR: | "__pipe__" }
+ { CHAR: / "__slash__" }
+ { CHAR: , "__comma__" }
+ { CHAR: @ "__at__" }
+ } at [ % ] [ , ] ?if
+ ] [ number>string "__" "__" surround % ] if ;
: escape-filename ( string -- filename )
[ [ escape-char ] each ] "" make ;
: help>html ( topic -- xml )
[ article-title ]
[ drop help-stylesheet ]
- [ [ help ] with-html-writer ]
+ [ [ print-topic ] with-html-writer ]
tri simple-page ;
: generate-help-file ( topic -- )
--- /dev/null
+extensions
IN: help.tips
USING: help.markup help.syntax debugger prettyprint see help help.vocabs
-help.apropos tools.time stack-checker editors ;
+help.apropos tools.time stack-checker editors memory ;
TIP: "To look at the most recent error, run " { $link :error } ". To look at the most recent error's callstack, run " { $link :c } "." ;
TIP: "Tips of the day implement the " { $link "definition-protocol" } " and new tips of the day can be defined using the " { $link POSTPONE: TIP: } " parsing word." ;
+TIP: "Try some simple demo applications, then look at the source code in " { $snippet "extra/" } ": " { $snippet "\"demos\" run" } ;
+
+TIP: "To save time on reloading big libraries such as the " { $vocab-link "furnace" } " web framework, save the image after loading them using the " { $link save } " word." ;
+
HELP: TIP:
{ $syntax "TIP: content ;" }
{ $values { "content" "a markup element" } }
USING: parser words definitions kernel sequences assocs arrays
kernel.private fry combinators accessors vectors strings sbufs
byte-arrays byte-vectors io.binary io.streams.string splitting
-math generic generic.standard generic.standard.engines classes
+math math.parser generic generic.standard generic.standard.engines classes
hashtables ;
IN: hints
[ drop object eq? not ] assoc-filter
[ [ t ] ] [
[ swap specializer-predicate append ] { } assoc>map
- unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
+ [ ] [ swap [ f ] \ if 3array append [ ] like ] map-reduce
] if-empty ;
: specializer-cases ( quot word -- default alist )
SYNTAX: HINTS:
scan-object
- dup method-spec? [ first2 method ] when
[ redefined ]
[ parse-definition "specializer" set-word-prop ] bi ;
\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
-\ hashtable \ at* method { { fixnum object } { word object } } "specializer" set-word-prop
+\ base> { string fixnum } "specializer" set-word-prop
-\ hashtable \ set-at method { { object fixnum object } { object word object } } "specializer" set-word-prop
+M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop
+
+M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop
io io.sockets io.streams.string io.files io.timeouts
io.pathnames io.encodings io.encodings.string io.encodings.ascii
io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.crlf
-io.streams.duplex fry ascii urls urls.encoding present
+io.streams.duplex fry ascii urls urls.encoding present locals
http http.parsers http.client.post-data ;
IN: http.client
: redirect? ( response -- ? )
code>> 300 399 between? ;
-: do-redirect ( quot: ( chunk -- ) response -- response )
+:: do-redirect ( quot: ( chunk -- ) response -- response )
redirects inc
redirects get max-redirects < [
request get clone
- swap "location" header redirect-url
- "GET" >>method swap (with-http-request)
+ response "location" header redirect-url
+ response code>> 307 = [ "GET" >>method ] unless
+ quot (with-http-request)
] [ too-many-redirects ] if ; inline recursive
: read-chunk-size ( -- n )
present file-name "?" split1 drop "/" ?tail drop ;
: download-to ( url file -- )
- binary [ [ write ] with-http-get drop ] with-file-writer ;
+ binary [ [ write ] with-http-get check-response drop ] with-file-writer ;
: download ( url -- )
dup download-name download-to ;
-USING: http http.server http.client http.client.private tools.test multiline
-io.streams.string io.encodings.utf8 io.encodings.8-bit
-io.encodings.binary io.encodings.string kernel arrays splitting
-sequences assocs io.sockets db db.sqlite continuations urls
-hashtables accessors namespaces xml.data ;
+USING: http http.server http.client http.client.private tools.test
+multiline io.streams.string io.encodings.utf8 io.encodings.8-bit
+io.encodings.binary io.encodings.string io.encodings.ascii kernel
+arrays splitting sequences assocs io.sockets db db.sqlite
+continuations urls hashtables accessors namespaces xml.data ;
IN: http.tests
[ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test
! Test basic auth
[ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ <request> "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test
+! Test a corner case with static responder
+[ ] [
+ <dispatcher>
+ add-quit-action
+ "vocab:http/test/foo.html" <static> >>default
+ test-httpd
+] unit-test
+
+[ t ] [
+ "http://localhost/" add-port http-get nip
+ "vocab:http/test/foo.html" ascii file-contents =
+] unit-test
+
+[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
+
+! Check behavior of 307 redirect (reported by Chris Double)
+[ ] [
+ <dispatcher>
+ add-quit-action
+ <action>
+ [ "b" <temporary-redirect> ] >>submit
+ "a" add-responder
+ <action>
+ [
+ request get post-data>> data>> "data" =
+ [ "OK" "text/plain" <content> ] [ "OOPS" throw ] if
+ ] >>submit
+ "b" add-responder
+ test-httpd
+] unit-test
+
+[ "OK" ] [ "data" "http://localhost/a" add-port http-post nip ] unit-test
+
+! Check that download throws errors (reported by Chris Double)
+[
+ "resource:temp" [
+ "http://localhost/tweet_my_twat" add-port download
+ ] with-directory
+] must-fail
+[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
if ;\r
\r
: serving-path ( filename -- filename )\r
- [ file-responder get root>> trim-tail-separators "/" ] dip\r
- "" or trim-head-separators 3append ;\r
+ [ file-responder get root>> trim-tail-separators ] dip\r
+ [ "/" swap trim-head-separators 3append ] unless-empty ;\r
\r
: serve-file ( filename -- response )\r
dup mime-type\r
USING: images.bitmap images.viewer io.encodings.binary
io.files io.files.unique kernel tools.test images.loader
-literals sequences ;
+literals sequences checksums.md5 checksums
+images.normalization ;
IN: images.bitmap.tests
CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp"
CONSTANT: test-bitmap1 "vocab:images/test-images/1bit.bmp"
-[ t ]
-[
- test-bitmap24
- [ binary file-contents ] [ load-image ] bi
-
- "test-bitmap24" unique-file
- [ save-bitmap ] [ binary file-contents ] bi =
-] unit-test
+CONSTANT: test-40 "vocab:images/test-images/40red24bit.bmp"
+CONSTANT: test-41 "vocab:images/test-images/41red24bit.bmp"
+CONSTANT: test-42 "vocab:images/test-images/42red24bit.bmp"
+CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp"
{
$ test-bitmap8
$ test-bitmap24
"vocab:ui/render/test/reference.bmp"
-} [ [ ] swap [ load-image drop ] curry unit-test ] each
\ No newline at end of file
+} [ [ ] swap [ load-image drop ] curry unit-test ] each
+
+
+: test-bitmap-save ( path -- ? )
+ [ md5 checksum-file ]
+ [ load-image normalize-image ] bi
+ "bitmap-save-test" unique-file
+ [ save-bitmap ]
+ [ md5 checksum-file ] bi = ;
+
+[
+ t
+] [
+ {
+ $ test-40
+ $ test-41
+ $ test-42
+ $ test-43
+ $ test-bitmap24
+ } [ test-bitmap-save ] all?
+] unit-test
ERROR: bmp-not-supported n ;
: reverse-lines ( byte-array width -- byte-array )
- 3 * <sliced-groups> <reversed> concat ; inline
+ <sliced-groups> <reversed> concat ; inline
: raw-bitmap>seq ( loading-bitmap -- array )
dup bit-count>>
{
{ 32 [ color-index>> ] }
- { 24 [ [ color-index>> ] [ width>> ] bi reverse-lines ] }
- { 8 [ [ 8bit>buffer ] [ width>> ] bi reverse-lines ] }
+ { 24 [ [ color-index>> ] [ width>> 3 * ] bi reverse-lines ] }
+ { 8 [ [ 8bit>buffer ] [ width>> 3 * ] bi reverse-lines ] }
[ bmp-not-supported ]
} case >byte-array ;
: image-size ( loading-bitmap -- n )
[ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
+: bitmap-padding ( width -- n )
+ 3 * 4 mod 4 swap - 4 mod ; inline
+
:: fixup-color-index ( loading-bitmap -- loading-bitmap )
loading-bitmap width>> :> width
width 3 * :> width*3
- loading-bitmap height>> abs :> height
- loading-bitmap color-index>> length :> color-index-length
- color-index-length height /i :> stride
- color-index-length width*3 height * - height /i :> padding
+ loading-bitmap width>> bitmap-padding :> padding
+ loading-bitmap [ color-index>> length ] [ height>> abs ] bi /i :> stride
+ loading-bitmap
padding 0 > [
- loading-bitmap [
+ [
stride <sliced-groups>
[ width*3 head-slice ] map concat
] change-color-index
- ] [
- loading-bitmap
- ] if ;
+ ] when ;
: parse-bitmap ( loading-bitmap -- loading-bitmap )
dup rgb-quads-length read >>rgb-quads
dup color-index-length read >>color-index
fixup-color-index ;
-: load-bitmap-data ( path loading-bitmap -- loading-bitmap )
- [ binary ] dip '[
- _ parse-file-header parse-bitmap-header parse-bitmap
+: load-bitmap-data ( path -- loading-bitmap )
+ binary [
+ loading-bitmap new
+ parse-file-header parse-bitmap-header parse-bitmap
] with-file-reader ;
ERROR: unknown-component-order bitmap ;
[ unknown-component-order ]
} case ;
-: loading-bitmap>bitmap-image ( loading-bitmap -- bitmap-image )
- [ bitmap-image new ] dip
+: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image )
{
[ raw-bitmap>seq >>bitmap ]
[ [ width>> ] [ height>> abs ] bi 2array >>dim ]
} cleave ;
M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
- drop loading-bitmap new
- load-bitmap-data
- loading-bitmap>bitmap-image ;
+ swap load-bitmap-data loading-bitmap>bitmap-image ;
PRIVATE>
-: bitmap>color-index ( bitmap-array -- byte-array )
- 4 <sliced-groups> [ 3 head-slice <reversed> ] map B{ } join ; inline
+: bitmap>color-index ( bitmap -- byte-array )
+ [
+ bitmap>>
+ 4 <sliced-groups>
+ [ 3 head-slice <reversed> ] map
+ B{ } join
+ ] [
+ dim>> first dup bitmap-padding dup 0 > [
+ [ 3 * group ] dip '[ _ <byte-array> append ] map
+ B{ } join
+ ] [
+ 2drop
+ ] if
+ ] bi ;
: save-bitmap ( image path -- )
binary [
B{ CHAR: B CHAR: M } write
[
- bitmap>> bitmap>color-index length 14 + 40 + write4
+ bitmap>color-index length 14 + 40 + write4
0 write4
54 write4
40 write4
[ drop 0 write4 ]
! size-image
- [ bitmap>> bitmap>color-index length write4 ]
+ [ bitmap>color-index length write4 ]
! x-pels
[ drop 0 write4 ]
! rgb-quads
[
- [ bitmap>> bitmap>color-index ] [ dim>> first ] bi
+ [ bitmap>color-index ]
+ [ dim>> first 3 * ]
+ [ dim>> first bitmap-padding + ] tri
reverse-lines write
]
} cleave
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel ;
+USING: combinators kernel accessors ;
IN: images
-SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
+SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
+UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
+
: bytes-per-pixel ( component-order -- n )
{
{ L [ 1 ] }
+ { LA [ 2 ] }
{ BGR [ 3 ] }
{ RGB [ 3 ] }
{ BGRA [ 4 ] }
: <image> ( -- image ) image new ; inline
-GENERIC: load-image* ( path tuple -- image )
\ No newline at end of file
+: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
+
+GENERIC: load-image* ( path tuple -- image )
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: constructors kernel splitting unicode.case combinators
-accessors images.bitmap images.tiff images images.normalization
-io.pathnames ;
+accessors images.bitmap images.tiff images io.pathnames ;
IN: images.loader
ERROR: unknown-image-extension extension ;
} case ;
: load-image ( path -- image )
- dup image-class new load-image* normalize-image ;
+ dup image-class new load-image* ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors grouping sequences combinators
-math specialized-arrays.direct.uint byte-arrays fry
-specialized-arrays.direct.ushort specialized-arrays.uint
-specialized-arrays.ushort specialized-arrays.float images ;
-IN: images.normalization
-
-<PRIVATE
-
-: add-dummy-alpha ( seq -- seq' )
- 3 <groups> [ 255 suffix ] map concat ;
-
-: normalize-floats ( byte-array -- byte-array )
- byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
-
-GENERIC: normalize-component-order* ( image component-order -- image )
-
-: normalize-component-order ( image -- image )
- dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
-
-M: RGBA normalize-component-order* drop ;
-
-M: R32G32B32A32 normalize-component-order*
- drop normalize-floats ;
-
-M: R32G32B32 normalize-component-order*
- drop normalize-floats add-dummy-alpha ;
-
-: RGB16>8 ( bitmap -- bitmap' )
- byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
-
-M: R16G16B16A16 normalize-component-order*
- drop RGB16>8 ;
-
-M: R16G16B16 normalize-component-order*
- drop RGB16>8 add-dummy-alpha ;
-
-: BGR>RGB ( bitmap -- pixels )
- 3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
-
-: BGRA>RGBA ( bitmap -- pixels )
- 4 <sliced-groups>
- [ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
-
-M: BGRA normalize-component-order*
- drop BGRA>RGBA ;
-
-M: RGB normalize-component-order*
- drop add-dummy-alpha ;
-
-M: BGR normalize-component-order*
- drop BGR>RGB add-dummy-alpha ;
-
-: ARGB>RGBA ( bitmap -- bitmap' )
- 4 <groups> [ unclip suffix ] map B{ } join ; inline
-
-M: ARGB normalize-component-order*
- drop ARGB>RGBA ;
-
-M: ABGR normalize-component-order*
- drop ARGB>RGBA BGRA>RGBA ;
-
-: normalize-scan-line-order ( image -- image )
- dup upside-down?>> [
- dup dim>> first 4 * '[
- _ <groups> reverse concat
- ] change-bitmap
- f >>upside-down?
- ] when ;
-
-PRIVATE>
-
-: normalize-image ( image -- image )
- [ >byte-array ] change-bitmap
- normalize-component-order
- normalize-scan-line-order
- RGBA >>component-order ;
{ { 16 16 16 } [ 2 seq>native-endianness ] }
{ { 8 8 8 8 } [ ] }
{ { 8 8 8 } [ ] }
+ { 8 [ ] }
[ unknown-component-order ]
} case >>bitmap ;
{ { 16 16 16 } [ R16G16B16 ] }
{ { 8 8 8 8 } [ RGBA ] }
{ { 8 8 8 } [ RGB ] }
+ { 8 [ LA ] }
[ unknown-component-order ]
} case ;
: normalize-alpha-data ( seq -- byte-array )
- ! [ normalize-alpha-data ] change-bitmap
B{ } like dup
byte-array>float-array
4 <sliced-groups>
--- /dev/null
+extensions
HELP: unique-file
{ $values
+ { "prefix" string }
{ "path" "a pathname string" }
- { "path'" "a pathname string" }
}
{ $description "Creates a temporary file in the directory stored in " { $link current-temporary-directory } " and outputs the path name." } ;
[ unique-directory ] dip
'[ _ with-temporary-directory ] [ delete-tree ] bi ; inline
-: unique-file ( path -- path' )
+: unique-file ( prefix -- path )
"" make-unique-file ;
{
[ decoder? ] both?
] with-destructors
] unit-test
+
+[ "HELL" ] [
+ "HELLO"
+ [ f stream-throws limit-input 4 read ]
+ with-string-reader
+] unit-test
\ No newline at end of file
[ clone ] 2dip '[ _ _ limit ] change-stream ;
M: object limit ( stream limit mode -- stream' )
- <limited-stream> ;
+ over [ <limited-stream> ] [ 2drop ] if ;
GENERIC: unlimited ( stream -- stream' )
M: object unlimited ( stream -- stream' )
stream>> stream>> ;
-: limit-input ( limit mode -- ) input-stream [ -rot limit ] change ;
+: limit-input ( limit mode -- )
+ [ input-stream ] 2dip '[ _ _ limit ] change ;
-: unlimited-input ( -- ) input-stream [ unlimited ] change ;
+: unlimited-input ( -- )
+ input-stream [ unlimited ] change ;
: with-unlimited-stream ( stream quot -- )
[ clone unlimited ] dip call ; inline
0 1 ? + [ [ 1+ ] bi@ ] dip min min ;\r
\r
: lcs-step ( insert delete change same? -- next )\r
- 1 -1./0. ? + max max ; ! -1./0. is -inf (float)\r
+ 1 -1/0. ? + max max ; ! -1/0. is -inf (float)\r
\r
:: loop-step ( i j matrix old new step -- )\r
i j 1+ matrix nth nth ! insertion\r
{ $description "Defines a memoized word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." } ;
{ POSTPONE: MEMO: POSTPONE: MEMO:: } related-words
+
+HELP: M::
+{ $syntax "M:: class generic ( bindings... -- outputs... ) body... ;" }
+{ $description "Defines a method with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." }
+{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." } ;
+
+{ POSTPONE: M: POSTPONE: M:: } related-words
+
ARTICLE: "locals-literals" "Locals in 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 reason is that locals are rewritten into stack code at parse time, whereas macro expansion is performed later during compile time. To circumvent this problem, the " { $vocab-link "macros.expander" } " vocabulary is used to rewrite simple macro usages prior to local transformation, however "{ $vocab-link "macros.expander" } " does not deal with more complicated cases where the literal inputs to the macro do not immediately precede the macro call in the source." ;
-ARTICLE: "locals" "Local variables and lexical closures"
+ARTICLE: "locals" "Lexical variables and closures"
"The " { $vocab-link "locals" } " vocabulary implements lexical scope with full closures, both downward and upward. Mutable bindings are supported, including assignment to bindings in outer scope."
$nl
"Compile-time transformation is used to compile local variables to efficient code; prettyprinter extensions are defined so that " { $link see } " can display original word definitions with local variables and not the closure-converted concatenative code which results."
$nl
"Applicative word definitions where the inputs are named local variables:"
{ $subsection POSTPONE: :: }
+{ $subsection POSTPONE: M:: }
{ $subsection POSTPONE: MEMO:: }
{ $subsection POSTPONE: MACRO:: }
"Lexical binding forms:"
M:: integer lambda-method-forget-test ( a -- b ) ;
-[ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test
+[ ] [ [ M\ integer lambda-method-forget-test forget ] with-compilation-unit ] unit-test
[ 10 ] [ 10 [| A | { [ A ] } ] call first call ] unit-test
--- /dev/null
+USING: alien.fortran help.markup help.syntax math.blas.config multiline ;
+IN: math.blas.config
+
+ARTICLE: "math.blas.config" "Configuring the BLAS interface"
+"The " { $link "math.blas-summary" } " chooses the underlying BLAS interface to use based on the values of the following global variables:"
+{ $subsection blas-library }
+{ $subsection blas-fortran-abi }
+"The interface attempts to set default values based on the ones encountered on the Factor project's build machines. If these settings don't work with your system's BLAS, or you wish to use a commercial BLAS, you may change the global values of those variables in your " { $link "factor-rc" } ". For example, to use AMD's ACML library on Windows with " { $snippet "math.blas" } ", your " { $snippet "factor-rc" } " would look like this:"
+{ $code <"
+USING: math.blas.config namespaces ;
+"X:\\path\\to\\acml.dll" blas-library set-global
+intel-windows-abi blas-fortran-abi set-global
+"> }
+"To take effect, the " { $snippet "blas-library" } " and " { $snippet "blas-fortran-abi" } " variables must be set before any other " { $snippet "math.blas" } " vocabularies are loaded."
+;
+
+HELP: blas-library
+{ $description "The name of the shared library containing the BLAS interface to load. The value of this variable must be a valid shared library name that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
+
+HELP: blas-fortran-abi
+{ $description "The Fortran ABI used by the BLAS interface specified in the " { $link blas-library } " variable. The value of " { $snippet "blas-fortran-abi" } " must be one of the " { $link "alien.fortran-abis" } " that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
+
+ABOUT: "math.blas.config"
--- /dev/null
+USING: alien.fortran combinators kernel namespaces system ;
+IN: math.blas.config
+
+SYMBOLS: blas-library blas-fortran-abi ;
+
+blas-library [
+ {
+ { [ os macosx? ] [ "libblas.dylib" ] }
+ { [ os windows? ] [ "blas.dll" ] }
+ [ "libblas.so" ]
+ } cond
+] initialize
+
+blas-fortran-abi [
+ {
+ { [ os macosx? ] [ intel-unix-abi ] }
+ { [ os windows? cpu x86.32? and ] [ f2c-abi ] }
+ { [ os netbsd? cpu x86.64? and ] [ g95-abi ] }
+ { [ os windows? cpu x86.64? and ] [ gfortran-abi ] }
+ { [ os freebsd? ] [ gfortran-abi ] }
+ { [ os linux? cpu x86.32? and ] [ gfortran-abi ] }
+ [ f2c-abi ]
+ } cond
+] initialize
-USING: alien alien.fortran kernel system combinators
-alien.libraries ;
+USING: alien.fortran kernel math.blas.config namespaces ;
IN: math.blas.ffi
<<
-"blas" {
- { [ os macosx? ] [ "libblas.dylib" intel-unix-abi add-fortran-library ] }
- { [ os windows? cpu x86.32? and ] [ "blas.dll" f2c-abi add-fortran-library ] }
- { [ os windows? cpu x86.64? and ] [ "blas.dll" gfortran-abi add-fortran-library ] }
- {
- [ os [ freebsd? ] [ linux? cpu x86.32? and ] bi or ]
- [ "libblas.so" gfortran-abi add-fortran-library ]
- }
- { [ os [ freebsd? ] [ linux? ] bi or ] [ "libblas.so" gfortran-abi add-fortran-library ] }
- [ "libblas.so" f2c-abi add-fortran-library ]
-} cond
+"blas" blas-library blas-fortran-abi [ get ] bi@
+add-fortran-library
>>
LIBRARY: blas
IN: math.blas.matrices
ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
-"Factor provides an interface to high-performance vector and matrix math routines available in the system's BLAS library. A set of specialized types are provided for handling packed, unboxed vector data:"
+"Factor provides an interface to high-performance vector and matrix math routines available in implementations of the BLAS math library. A set of specialized types are provided for handling packed, unboxed vector data:"
{ $subsection "math.blas-types" }
"Scalar-vector and vector-vector operations are available in the " { $vocab-link "math.blas.vectors" } " vocabulary:"
{ $subsection "math.blas.vectors" }
"Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:"
{ $subsection "math.blas.matrices" }
-"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary." ;
+"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary. The BLAS interface can be configured to use different underlying BLAS implementations:"
+{ $subsection "math.blas.config" } ;
ARTICLE: "math.blas-types" "BLAS interface types"
"BLAS vectors come in single- and double-precision, real and complex flavors:"
"Tests:"
{ $subsection power-of-2? }
{ $subsection even? }
-{ $subsection odd? } ;
+{ $subsection odd? }
+{ $subsection divisor? } ;
ARTICLE: "arithmetic-functions" "Arithmetic functions"
"Computing additive and multiplicative inverses:"
{ $description "Computes the positive greatest common divisor " { $snippet "d" } " of " { $snippet "x" } " and " { $snippet "y" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*y = d mod x" } }
{ $notes "If " { $snippet "d" } " is 1, then " { $snippet "a" } " is the inverse of " { $snippet "y" } " modulo " { $snippet "x" } "." } ;
+HELP: divisor?
+{ $values { "m" integer } { "n" integer } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "n" } " is a divisor of " { $snippet "m" } ". This is the same thing as asking if " { $snippet "m" } " is divisible by " { $snippet "n" } "." }
+{ $notes "Returns t for both negative and positive divisors, as well as for trivial and non-trivial divisors." } ;
+
HELP: mod-inv
{ $values { "x" integer } { "n" integer } { "y" integer } }
{ $description "Outputs an integer " { $snippet "y" } " such that " { $snippet "xy = 1 (mod n)" } "." }
[ t ] [ e pi i* ^ imaginary-part -0.00001 0.00001 between? ] unit-test
[ t ] [ 0 0 ^ fp-nan? ] unit-test
-[ 1.0/0.0 ] [ 0 -2 ^ ] unit-test
+[ 1/0. ] [ 0 -2 ^ ] unit-test
[ t ] [ 0 0.0 ^ fp-nan? ] unit-test
-[ 1.0/0.0 ] [ 0 -2.0 ^ ] unit-test
+[ 1/0. ] [ 0 -2.0 ^ ] unit-test
[ 0 ] [ 0 3.0 ^ ] unit-test
[ 0 ] [ 0 3 ^ ] unit-test
[ 1.0 ] [ 0 cosh ] unit-test
[ 0.0 ] [ 1 acosh ] unit-test
-
+
[ 1.0 ] [ 0 cos ] unit-test
[ 0.0 ] [ 1 acos ] unit-test
-
+
[ 0.0 ] [ 0 sinh ] unit-test
[ 0.0 ] [ 0 asinh ] unit-test
-
+
[ 0.0 ] [ 0 sin ] unit-test
[ 0.0 ] [ 0 asin ] unit-test
: verify-gcd ( a b -- ? )
2dup gcd
- [ rot * swap rem ] dip = ;
+ [ rot * swap rem ] dip = ;
[ t ] [ 123 124 verify-gcd ] unit-test
[ t ] [ 50 120 verify-gcd ] unit-test
+[ t ] [ 0 42 divisor? ] unit-test
+[ t ] [ 42 7 divisor? ] unit-test
+[ t ] [ 42 -7 divisor? ] unit-test
+[ t ] [ 42 42 divisor? ] unit-test
+[ f ] [ 42 16 divisor? ] unit-test
+
[ 3 ] [ 5 7 mod-inv ] unit-test
[ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test
1067811677921310779
2135623355842621559
[ >bignum ] tri@ ^mod
-] unit-test
\ No newline at end of file
+] unit-test
2dup [ real? ] both? [ drop 0 >= ] [ 2drop f ] if ; inline
: 0^ ( x -- z )
- dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline
+ dup zero? [ drop 0/0. ] [ 0 < 1/0. 0 ? ] if ; inline
: (^mod) ( n x y -- z )
make-bits 1 [
: lcm ( a b -- c )
[ * ] 2keep gcd nip /i ; foldable
+: divisor? ( m n -- ? )
+ mod 0 = ;
+
: mod-inv ( x n -- y )
[ nip ] [ gcd 1 = ] 2bi
[ dup 0 < [ + ] [ nip ] if ]
GENERIC: sinh ( x -- y ) foldable
-M: complex sinh
+M: complex sinh
>float-rect
[ [ fsinh ] [ fcos ] bi* * ]
[ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;
: [a,a] ( a -- interval )
closed-point dup <interval> ; foldable
-: [-inf,a] ( a -- interval ) -1./0. swap [a,b] ; inline
+: [-inf,a] ( a -- interval ) -1/0. swap [a,b] ; inline
-: [-inf,a) ( a -- interval ) -1./0. swap [a,b) ; inline
+: [-inf,a) ( a -- interval ) -1/0. swap [a,b) ; inline
-: [a,inf] ( a -- interval ) 1./0. [a,b] ; inline
+: [a,inf] ( a -- interval ) 1/0. [a,b] ; inline
-: (a,inf] ( a -- interval ) 1./0. (a,b] ; inline
+: (a,inf] ( a -- interval ) 1/0. (a,b] ; inline
: [-inf,inf] ( -- interval ) full-interval ; inline
$nl
"They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
{ $example "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" }
-{ $unchecked-example "USE: math.libm" "2 facos ." "0.0/0.0" }
+{ $unchecked-example "USE: math.libm" "2 facos ." "0/0." }
"Trigonometric functions:"
{ $subsection fcos }
{ $subsection fsin }
! Copyright (C) 2007-2009 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators kernel make math math.primes sequences ;
+USING: arrays combinators kernel make math math.functions math.primes sequences ;
IN: math.primes.factors
<PRIVATE
swap ;
: write-factor ( n d -- n' d' )
- 2dup mod zero? [
+ 2dup divisor? [
[ [ count-factor ] keep swap 2array , ] keep
! If the remainder is a prime number, increase d so that
! the caller stops looking for factors.
IN: math.ranges
-ARTICLE: "ranges" "Ranges"
+ARTICLE: "math.ranges" "Numeric ranges"
"A " { $emphasis "range" } " is a virtual sequence with real number elements "
"ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } ". Ascending as well as descending ranges are supported."
$nl
{ $code "100 1 [a,b] product" }
"A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link change-each } "." ;
-ABOUT: "ranges"
\ No newline at end of file
+ABOUT: "math.ranges"
\ No newline at end of file
--- /dev/null
+IN: models.arrow.smart
+USING: help.syntax help.markup models.product ;
+
+HELP: <smart-arrow>
+{ $values { "quot" { $quotation "( ... -- output )" } } }
+{ $description "A macro that expands into a form with the stack effect of the quotation. The form constructs a model which applies the quotation to values from an underlying " { $link product } " model having as many components as the quotation has inputs." }
+{ $examples
+ "A model which adds the values of two existing models:"
+ { $example
+ "USING: models models.arrows.smart accessors math prettyprint ;"
+ "1 <model> 2 <model> [ + ] <smart-arrow>"
+ "[ activate-model ] [ value>> ] bi ."
+ "3"
+ }
+} ;
+
+ARTICLE: "models.arrows.smart" "Smart arrow models"
+"The " { $vocab-link "models.arrows.smart" } " vocabulary generalizes arrows to arbitrary input arity. They're called “smart” because they resemble " { $link "combinators.smart" } "."
+{ $subsection <smart-arrow> } ;
+
+ABOUT: "models.arrows.smart"
\ No newline at end of file
+++ /dev/null
-USING: help.syntax help.markup kernel math classes classes.tuple\r
-calendar models ;\r
-IN: models.history\r
-\r
-HELP: history\r
-{ $class-description "History models record a timeline of previous values on calls to " { $link add-history } ", and can travel back and forth on the timeline with " { $link go-back } " and " { $link go-forward } ". History models are constructed by " { $link <history> } "." } ;\r
-\r
-HELP: <history>\r
-{ $values { "value" object } { "history" "a new " { $link history } } }\r
-{ $description "Creates a new history model with an initial value." } ;\r
-\r
-{ <history> add-history go-back go-forward } related-words\r
-\r
-HELP: go-back\r
-{ $values { "history" history } }\r
-{ $description "Restores the previous value and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;\r
-\r
-HELP: go-forward\r
-{ $values { "history" history } }\r
-{ $description "Restores the value set prior to the last call to " { $link go-back } " and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;\r
-\r
-HELP: add-history\r
-{ $values { "history" history } }\r
-{ $description "Adds the current value to the history." } ;\r
-\r
-ARTICLE: "models-history" "History models"\r
-"History models record previous values."\r
-{ $subsection history }\r
-{ $subsection <history> }\r
-"Recording history:"\r
-{ $subsection add-history }\r
-"Navigating the history:"\r
-{ $subsection go-back }\r
-{ $subsection go-forward } ;\r
-\r
-ABOUT: "models-history"\r
+++ /dev/null
-USING: arrays generic kernel math models namespaces sequences assocs\r
-tools.test models.history accessors ;\r
-IN: models.history.tests\r
-\r
-f <history> "history" set\r
-\r
-"history" get add-history\r
-\r
-[ t ] [ "history" get back>> empty? ] unit-test\r
-[ t ] [ "history" get forward>> empty? ] unit-test\r
-\r
-"history" get add-history\r
-3 "history" get set-model\r
-\r
-[ t ] [ "history" get back>> empty? ] unit-test\r
-[ t ] [ "history" get forward>> empty? ] unit-test\r
-\r
-"history" get add-history\r
-4 "history" get set-model\r
-\r
-[ f ] [ "history" get back>> empty? ] unit-test\r
-[ t ] [ "history" get forward>> empty? ] unit-test\r
-\r
-"history" get go-back\r
-\r
-[ 3 ] [ "history" get value>> ] unit-test\r
-\r
-[ t ] [ "history" get back>> empty? ] unit-test\r
-[ f ] [ "history" get forward>> empty? ] unit-test\r
-\r
-"history" get go-forward\r
-\r
-[ 4 ] [ "history" get value>> ] unit-test\r
-\r
-[ f ] [ "history" get back>> empty? ] unit-test\r
-[ t ] [ "history" get forward>> empty? ] unit-test\r
-\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors kernel models sequences ;\r
-IN: models.history\r
-\r
-TUPLE: history < model back forward ;\r
-\r
-: reset-history ( history -- history )\r
- V{ } clone >>back\r
- V{ } clone >>forward ; inline\r
-\r
-: <history> ( value -- history )\r
- history new-model\r
- reset-history ;\r
-\r
-: (add-history) ( history to -- )\r
- swap value>> dup [ swap push ] [ 2drop ] if ;\r
-\r
-: go-back/forward ( history to from -- )\r
- [ 2drop ]\r
- [ [ dupd (add-history) ] dip pop swap set-model ] if-empty ;\r
-\r
-: go-back ( history -- )\r
- dup [ forward>> ] [ back>> ] bi go-back/forward ;\r
-\r
-: go-forward ( history -- )\r
- dup [ back>> ] [ forward>> ] bi go-back/forward ;\r
-\r
-: add-history ( history -- )\r
- dup forward>> delete-all\r
- dup back>> (add-history) ;\r
+++ /dev/null
-History models remember prior values
{ $subsection "models-impl" }
{ $subsection "models.arrow" }
{ $subsection "models.product" }
-{ $subsection "models-history" }
{ $subsection "models-range" }
{ $subsection "models-delay" } ;
Slava Pestov
Eduardo Cavazos
Joe Groff
+Alex Chapman
(gl-version) drop ;
: gl-vendor-version ( -- version )
(gl-version) nip ;
+: gl-vendor ( -- name )
+ GL_VENDOR glGetString ;
: has-gl-version? ( version -- ? )
gl-version version-before? ;
: (make-gl-version-error) ( required-version -- )
-Slava Pestov
+Alex Chapman
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2005 Alex Chapman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax kernel sequences words ;
-IN: opengl.glu
-
-! These are defined as structs in glu.h, but we only ever use pointers to them
-TYPEDEF: void* GLUnurbs*
-TYPEDEF: void* GLUquadric*
-TYPEDEF: void* GLUtesselator*
-TYPEDEF: void* GLubyte*
-TYPEDEF: void* GLUfuncptr
-
-! StringName
-CONSTANT: GLU_VERSION 100800
-CONSTANT: GLU_EXTENSIONS 100801
-
-! ErrorCode
-CONSTANT: GLU_INVALID_ENUM 100900
-CONSTANT: GLU_INVALID_VALUE 100901
-CONSTANT: GLU_OUT_OF_MEMORY 100902
-CONSTANT: GLU_INCOMPATIBLE_GL_VERSION 100903
-CONSTANT: GLU_INVALID_OPERATION 100904
-
-! NurbsDisplay
-CONSTANT: GLU_OUTLINE_POLYGON 100240
-CONSTANT: GLU_OUTLINE_PATCH 100241
-
-! NurbsCallback
-CONSTANT: GLU_NURBS_ERROR 100103
-CONSTANT: GLU_ERROR 100103
-CONSTANT: GLU_NURBS_BEGIN 100164
-CONSTANT: GLU_NURBS_BEGIN_EXT 100164
-CONSTANT: GLU_NURBS_VERTEX 100165
-CONSTANT: GLU_NURBS_VERTEX_EXT 100165
-CONSTANT: GLU_NURBS_NORMAL 100166
-CONSTANT: GLU_NURBS_NORMAL_EXT 100166
-CONSTANT: GLU_NURBS_COLOR 100167
-CONSTANT: GLU_NURBS_COLOR_EXT 100167
-CONSTANT: GLU_NURBS_TEXTURE_COORD 100168
-CONSTANT: GLU_NURBS_TEX_COORD_EXT 100168
-CONSTANT: GLU_NURBS_END 100169
-CONSTANT: GLU_NURBS_END_EXT 100169
-CONSTANT: GLU_NURBS_BEGIN_DATA 100170
-CONSTANT: GLU_NURBS_BEGIN_DATA_EXT 100170
-CONSTANT: GLU_NURBS_VERTEX_DATA 100171
-CONSTANT: GLU_NURBS_VERTEX_DATA_EXT 100171
-CONSTANT: GLU_NURBS_NORMAL_DATA 100172
-CONSTANT: GLU_NURBS_NORMAL_DATA_EXT 100172
-CONSTANT: GLU_NURBS_COLOR_DATA 100173
-CONSTANT: GLU_NURBS_COLOR_DATA_EXT 100173
-CONSTANT: GLU_NURBS_TEXTURE_COORD_DATA 100174
-CONSTANT: GLU_NURBS_TEX_COORD_DATA_EXT 100174
-CONSTANT: GLU_NURBS_END_DATA 100175
-CONSTANT: GLU_NURBS_END_DATA_EXT 100175
-
-! NurbsError
-CONSTANT: GLU_NURBS_ERROR1 100251
-CONSTANT: GLU_NURBS_ERROR2 100252
-CONSTANT: GLU_NURBS_ERROR3 100253
-CONSTANT: GLU_NURBS_ERROR4 100254
-CONSTANT: GLU_NURBS_ERROR5 100255
-CONSTANT: GLU_NURBS_ERROR6 100256
-CONSTANT: GLU_NURBS_ERROR7 100257
-CONSTANT: GLU_NURBS_ERROR8 100258
-CONSTANT: GLU_NURBS_ERROR9 100259
-CONSTANT: GLU_NURBS_ERROR10 100260
-CONSTANT: GLU_NURBS_ERROR11 100261
-CONSTANT: GLU_NURBS_ERROR12 100262
-CONSTANT: GLU_NURBS_ERROR13 100263
-CONSTANT: GLU_NURBS_ERROR14 100264
-CONSTANT: GLU_NURBS_ERROR15 100265
-CONSTANT: GLU_NURBS_ERROR16 100266
-CONSTANT: GLU_NURBS_ERROR17 100267
-CONSTANT: GLU_NURBS_ERROR18 100268
-CONSTANT: GLU_NURBS_ERROR19 100269
-CONSTANT: GLU_NURBS_ERROR20 100270
-CONSTANT: GLU_NURBS_ERROR21 100271
-CONSTANT: GLU_NURBS_ERROR22 100272
-CONSTANT: GLU_NURBS_ERROR23 100273
-CONSTANT: GLU_NURBS_ERROR24 100274
-CONSTANT: GLU_NURBS_ERROR25 100275
-CONSTANT: GLU_NURBS_ERROR26 100276
-CONSTANT: GLU_NURBS_ERROR27 100277
-CONSTANT: GLU_NURBS_ERROR28 100278
-CONSTANT: GLU_NURBS_ERROR29 100279
-CONSTANT: GLU_NURBS_ERROR30 100280
-CONSTANT: GLU_NURBS_ERROR31 100281
-CONSTANT: GLU_NURBS_ERROR32 100282
-CONSTANT: GLU_NURBS_ERROR33 100283
-CONSTANT: GLU_NURBS_ERROR34 100284
-CONSTANT: GLU_NURBS_ERROR35 100285
-CONSTANT: GLU_NURBS_ERROR36 100286
-CONSTANT: GLU_NURBS_ERROR37 100287
-
-! NurbsProperty
-CONSTANT: GLU_AUTO_LOAD_MATRIX 100200
-CONSTANT: GLU_CULLING 100201
-CONSTANT: GLU_SAMPLING_TOLERANCE 100203
-CONSTANT: GLU_DISPLAY_MODE 100204
-CONSTANT: GLU_PARAMETRIC_TOLERANCE 100202
-CONSTANT: GLU_SAMPLING_METHOD 100205
-CONSTANT: GLU_U_STEP 100206
-CONSTANT: GLU_V_STEP 100207
-CONSTANT: GLU_NURBS_MODE 100160
-CONSTANT: GLU_NURBS_MODE_EXT 100160
-CONSTANT: GLU_NURBS_TESSELLATOR 100161
-CONSTANT: GLU_NURBS_TESSELLATOR_EXT 100161
-CONSTANT: GLU_NURBS_RENDERER 100162
-CONSTANT: GLU_NURBS_RENDERER_EXT 100162
-
-! NurbsSampling
-CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR 100208
-CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR_EXT 100208
-CONSTANT: GLU_OBJECT_PATH_LENGTH 100209
-CONSTANT: GLU_OBJECT_PATH_LENGTH_EXT 100209
-CONSTANT: GLU_PATH_LENGTH 100215
-CONSTANT: GLU_PARAMETRIC_ERROR 100216
-CONSTANT: GLU_DOMAIN_DISTANCE 100217
-
-! NurbsTrim
-CONSTANT: GLU_MAP1_TRIM_2 100210
-CONSTANT: GLU_MAP1_TRIM_3 100211
-
-! QuadricDrawStyle
-CONSTANT: GLU_POINT 100010
-CONSTANT: GLU_LINE 100011
-CONSTANT: GLU_FILL 100012
-CONSTANT: GLU_SILHOUETTE 100013
-
-! QuadricNormal
-CONSTANT: GLU_SMOOTH 100000
-CONSTANT: GLU_FLAT 100001
-CONSTANT: GLU_NONE 100002
-
-! QuadricOrientation
-CONSTANT: GLU_OUTSIDE 100020
-CONSTANT: GLU_INSIDE 100021
-
-! TessCallback
-CONSTANT: GLU_TESS_BEGIN 100100
-CONSTANT: GLU_BEGIN 100100
-CONSTANT: GLU_TESS_VERTEX 100101
-CONSTANT: GLU_VERTEX 100101
-CONSTANT: GLU_TESS_END 100102
-CONSTANT: GLU_END 100102
-CONSTANT: GLU_TESS_ERROR 100103
-CONSTANT: GLU_TESS_EDGE_FLAG 100104
-CONSTANT: GLU_EDGE_FLAG 100104
-CONSTANT: GLU_TESS_COMBINE 100105
-CONSTANT: GLU_TESS_BEGIN_DATA 100106
-CONSTANT: GLU_TESS_VERTEX_DATA 100107
-CONSTANT: GLU_TESS_END_DATA 100108
-CONSTANT: GLU_TESS_ERROR_DATA 100109
-CONSTANT: GLU_TESS_EDGE_FLAG_DATA 100110
-CONSTANT: GLU_TESS_COMBINE_DATA 100111
-
-! TessContour
-CONSTANT: GLU_CW 100120
-CONSTANT: GLU_CCW 100121
-CONSTANT: GLU_INTERIOR 100122
-CONSTANT: GLU_EXTERIOR 100123
-CONSTANT: GLU_UNKNOWN 100124
-
-! TessProperty
-CONSTANT: GLU_TESS_WINDING_RULE 100140
-CONSTANT: GLU_TESS_BOUNDARY_ONLY 100141
-CONSTANT: GLU_TESS_TOLERANCE 100142
-
-! TessError
-CONSTANT: GLU_TESS_ERROR1 100151
-CONSTANT: GLU_TESS_ERROR2 100152
-CONSTANT: GLU_TESS_ERROR3 100153
-CONSTANT: GLU_TESS_ERROR4 100154
-CONSTANT: GLU_TESS_ERROR5 100155
-CONSTANT: GLU_TESS_ERROR6 100156
-CONSTANT: GLU_TESS_ERROR7 100157
-CONSTANT: GLU_TESS_ERROR8 100158
-CONSTANT: GLU_TESS_MISSING_BEGIN_POLYGON 100151
-CONSTANT: GLU_TESS_MISSING_BEGIN_CONTOUR 100152
-CONSTANT: GLU_TESS_MISSING_END_POLYGON 100153
-CONSTANT: GLU_TESS_MISSING_END_CONTOUR 100154
-CONSTANT: GLU_TESS_COORD_TOO_LARGE 100155
-CONSTANT: GLU_TESS_NEED_COMBINE_CALLBACK 100156
-
-! TessWinding
-CONSTANT: GLU_TESS_WINDING_ODD 100130
-CONSTANT: GLU_TESS_WINDING_NONZERO 100131
-CONSTANT: GLU_TESS_WINDING_POSITIVE 100132
-CONSTANT: GLU_TESS_WINDING_NEGATIVE 100133
-CONSTANT: GLU_TESS_WINDING_ABS_GEQ_TWO 100134
-
-LIBRARY: glu
-
-FUNCTION: void gluBeginCurve ( GLUnurbs* nurb ) ;
-FUNCTION: void gluBeginPolygon ( GLUtesselator* tess ) ;
-FUNCTION: void gluBeginSurface ( GLUnurbs* nurb ) ;
-FUNCTION: void gluBeginTrim ( GLUnurbs* nurb ) ;
-
-FUNCTION: void gluCylinder ( GLUquadric* quad, GLdouble base, GLdouble top, GLdouble height, GLint slices, GLint stacks ) ;
-FUNCTION: void gluDeleteNurbsRenderer ( GLUnurbs* nurb ) ;
-FUNCTION: void gluDeleteQuadric ( GLUquadric* quad ) ;
-FUNCTION: void gluDeleteTess ( GLUtesselator* tess ) ;
-FUNCTION: void gluDisk ( GLUquadric* quad, GLdouble inner, GLdouble outer, GLint slices, GLint loops ) ;
-FUNCTION: void gluEndCurve ( GLUnurbs* nurb ) ;
-FUNCTION: void gluEndPolygon ( GLUtesselator* tess ) ;
-FUNCTION: void gluEndSurface ( GLUnurbs* nurb ) ;
-FUNCTION: void gluEndTrim ( GLUnurbs* nurb ) ;
-FUNCTION: char* gluErrorString ( GLenum error ) ;
-FUNCTION: void gluGetNurbsProperty ( GLUnurbs* nurb, GLenum property, GLfloat* data ) ;
-FUNCTION: char* gluGetString ( GLenum name ) ;
-FUNCTION: void gluGetTessProperty ( GLUtesselator* tess, GLenum which, GLdouble* data ) ;
-FUNCTION: void gluLoadSamplingMatrices ( GLUnurbs* nurb, GLfloat* model, GLfloat* perspective, GLint* view ) ;
-FUNCTION: void gluLookAt ( GLdouble eyeX, GLdouble eyeY, GLdouble eyeZ, GLdouble centerX, GLdouble centerY, GLdouble centerZ, GLdouble upX, GLdouble upY, GLdouble upZ ) ;
-FUNCTION: GLUnurbs* gluNewNurbsRenderer ( ) ;
-FUNCTION: GLUquadric* gluNewQuadric ( ) ;
-FUNCTION: GLUtesselator* gluNewTess ( ) ;
-FUNCTION: void gluNextContour ( GLUtesselator* tess, GLenum type ) ;
-FUNCTION: void gluNurbsCallback ( GLUnurbs* nurb, GLenum which, GLUfuncptr CallBackFunc ) ;
-! FUNCTION: void gluNurbsCallbackData ( GLUnurbs* nurb, GLvoid* userData ) ;
-! FUNCTION: void gluNurbsCallbackDataEXT ( GLUnurbs* nurb, GLvoid* userData ) ;
-FUNCTION: void gluNurbsCurve ( GLUnurbs* nurb, GLint knotCount, GLfloat *knots, GLint stride, GLfloat *control, GLint order, GLenum type ) ;
-FUNCTION: void gluNurbsProperty ( GLUnurbs* nurb, GLenum property, GLfloat value ) ;
-FUNCTION: void gluNurbsSurface ( GLUnurbs* nurb, GLint sKnotCount, GLfloat* sKnots, GLint tKnotCount, GLfloat* tKnots, GLint sStride, GLint tStride, GLfloat* control, GLint sOrder, GLint tOrder, GLenum type ) ;
-FUNCTION: void gluOrtho2D ( GLdouble left, GLdouble right, GLdouble bottom, GLdouble top ) ;
-FUNCTION: void gluPartialDisk ( GLUquadric* quad, GLdouble inner, GLdouble outer, GLint slices, GLint loops, GLdouble start, GLdouble sweep ) ;
-FUNCTION: void gluPerspective ( GLdouble fovy, GLdouble aspect, GLdouble zNear, GLdouble zFar ) ;
-FUNCTION: void gluPickMatrix ( GLdouble x, GLdouble y, GLdouble delX, GLdouble delY, GLint* viewport ) ;
-FUNCTION: GLint gluProject ( GLdouble objX, GLdouble objY, GLdouble objZ, GLdouble* model, GLdouble* proj, GLint* view, GLdouble* winX, GLdouble* winY, GLdouble* winZ ) ;
-FUNCTION: void gluPwlCurve ( GLUnurbs* nurb, GLint count, GLfloat* data, GLint stride, GLenum type ) ;
-FUNCTION: void gluQuadricCallback ( GLUquadric* quad, GLenum which, GLUfuncptr CallBackFunc ) ;
-FUNCTION: void gluQuadricDrawStyle ( GLUquadric* quad, GLenum draw ) ;
-FUNCTION: void gluQuadricNormals ( GLUquadric* quad, GLenum normal ) ;
-FUNCTION: void gluQuadricOrientation ( GLUquadric* quad, GLenum orientation ) ;
-FUNCTION: void gluQuadricTexture ( GLUquadric* quad, GLboolean texture ) ;
-FUNCTION: GLint gluScaleImage ( GLenum format, GLsizei wIn, GLsizei hIn, GLenum typeIn, void* dataIn, GLsizei wOut, GLsizei hOut, GLenum typeOut, GLvoid* dataOut ) ;
-FUNCTION: void gluSphere ( GLUquadric* quad, GLdouble radius, GLint slices, GLint stacks ) ;
-FUNCTION: void gluTessBeginContour ( GLUtesselator* tess ) ;
-FUNCTION: void gluTessBeginPolygon ( GLUtesselator* tess, GLvoid* data ) ;
-FUNCTION: void gluTessCallback ( GLUtesselator* tess, GLenum which, GLUfuncptr CallBackFunc ) ;
-FUNCTION: void gluTessEndContour ( GLUtesselator* tess ) ;
-FUNCTION: void gluTessEndPolygon ( GLUtesselator* tess ) ;
-FUNCTION: void gluTessNormal ( GLUtesselator* tess, GLdouble valueX, GLdouble valueY, GLdouble valueZ ) ;
-FUNCTION: void gluTessProperty ( GLUtesselator* tess, GLenum which, GLdouble data ) ;
-FUNCTION: void gluTessVertex ( GLUtesselator* tess, GLdouble* location, GLvoid* data ) ;
-FUNCTION: GLint gluUnProject ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble* model, GLdouble* proj, GLint* view, GLdouble* objX, GLdouble* objY, GLdouble* objZ ) ;
-
-! Not present on Windows
-! FUNCTION: GLint gluBuild1DMipmapLevels ( GLenum target, GLint internalFormat, GLsizei width, GLenum format, GLenum type, GLint level, GLint base, GLint max, void* data ) ;
-! FUNCTION: GLint gluBuild1DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLenum format, GLenum type, void* data ) ;
-! FUNCTION: GLint gluBuild2DMipmapLevels ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLenum format, GLenum type, GLint level, GLint base, GLint max, void* data ) ;
-! FUNCTION: GLint gluBuild2DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLenum format, GLenum type, void* data ) ;
-! FUNCTION: GLint gluBuild3DMipmapLevels ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, GLint level, GLint base, GLint max, void* data ) ;
-! FUNCTION: GLint gluBuild3DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, void* data ) ;
-! FUNCTION: GLboolean gluCheckExtension ( GLubyte* extName, GLubyte* extString ) ;
-! FUNCTION: GLint gluUnProject4 ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble clipW, GLdouble* model, GLdouble* proj, GLint* view, GLdouble nearVal, GLdouble farVal, GLdouble* objX, GLdouble* objY, GLdouble* objZ, GLdouble* objW ) ;
+++ /dev/null
-OpenGL binding - libGLU
{ $description "Wraps a quotation in " { $link glEnable } "/" { $link glDisable } " calls." } ;
HELP: do-matrix
-{ $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." } ;
+{ $values { "quot" quotation } }
+{ $description "Saves and restores the current matrix before and after calling the quotation." } ;
HELP: gl-line
{ $values { "a" "a pair of integers" } { "b" "a pair of integers" } }
! 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.parser opengl.gl opengl.glu combinators
+namespaces math.vectors math.parser opengl.gl combinators
combinators.smart arrays sequences splitting words byte-arrays assocs
colors colors.constants accessors generalizations locals fry
specialized-arrays.float specialized-arrays.uint ;
: gl-clear ( color -- )
gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
+: error>string ( n -- string )
+ H{
+ { HEX: 0 "No error" }
+ { HEX: 0501 "Invalid value" }
+ { HEX: 0500 "Invalid enumerant" }
+ { HEX: 0502 "Invalid operation" }
+ { HEX: 0503 "Stack overflow" }
+ { HEX: 0504 "Stack underflow" }
+ { HEX: 0505 "Out of memory" }
+ } at "Unknown error" or ;
+
+TUPLE: gl-error code string ;
+
: gl-error ( -- )
- glGetError dup zero? [
- "GL error: " over gluErrorString append throw
- ] unless drop ;
+ glGetError dup 0 = [ drop ] [
+ dup error>string \ gl-error boa throw
+ ] if ;
: do-enabled ( what quot -- )
over glEnable dip glDisable ; inline
MACRO: all-enabled-client-state ( seq quot -- )
[ words>values ] dip '[ _ _ (all-enabled-client-state) ] ;
-: do-matrix ( mode quot -- )
- swap [ glMatrixMode glPushMatrix call ] keep
- glMatrixMode glPopMatrix ; inline
+: do-matrix ( quot -- )
+ glPushMatrix call glPopMatrix ; inline
: gl-material ( face pname params -- )
float-array{ } like glMaterialfv ;
MACRO: set-draw-buffers ( buffers -- )
words>values '[ _ (set-draw-buffers) ] ;
-: gl-look-at ( eye focus up -- )
- [ first3 ] tri@ gluLookAt ;
-
: gen-dlist ( -- id ) 1 glGenLists ;
: make-dlist ( type quot -- id )
: delete-dlist ( id -- ) 1 glDeleteLists ;
: with-translation ( loc quot -- )
- GL_MODELVIEW [ [ gl-translate ] dip call ] do-matrix ; inline
+ [ [ gl-translate ] dip call ] do-matrix ; inline
: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
[ first2 [ >fixnum ] bi@ ] bi@ ;
fix-coordinates glViewport ;
: init-matrices ( -- )
+ #! Leaves with matrix mode GL_MODELVIEW
GL_PROJECTION glMatrixMode
glLoadIdentity
GL_MODELVIEW glMatrixMode
sequences ;
IN: opengl.textures.tests
-[ ] [
- T{ image
- { dim { 3 5 } }
- { component-order RGB }
- { bitmap
- B{
- 1 2 3 4 5 6 7 8 9
- 10 11 12 13 14 15 16 17 18
- 19 20 21 22 23 24 25 26 27
- 28 29 30 31 32 33 34 35 36
- 37 38 39 40 41 42 43 44 45
- }
- }
- } "image" set
-] unit-test
-
-[
- T{ image
- { dim { 4 8 } }
- { component-order RGB }
- { bitmap
- B{
- 1 2 3 4 5 6 7 8 9 7 8 9
- 10 11 12 13 14 15 16 17 18 16 17 18
- 19 20 21 22 23 24 25 26 27 25 26 27
- 28 29 30 31 32 33 34 35 36 34 35 36
- 37 38 39 40 41 42 43 44 45 43 44 45
- 37 38 39 40 41 42 43 44 45 43 44 45
- 37 38 39 40 41 42 43 44 45 43 44 45
- 37 38 39 40 41 42 43 44 45 43 44 45
- }
- }
- }
-] [
- "image" get power-of-2-image
-] unit-test
-
-[
- T{ image
- { dim { 0 0 } }
- { component-order R32G32B32 }
- { bitmap B{ } } }
-] [
- T{ image
- { dim { 0 0 } }
- { component-order R32G32B32 }
- { bitmap B{ } }
- } power-of-2-image
-] unit-test
-
[
{
{ { 0 0 } { 10 0 } }
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs cache colors.constants destructors fry kernel
-opengl opengl.gl combinators images images.tesselation grouping
-specialized-arrays.float locals sequences math math.vectors
-math.matrices generalizations fry columns ;
+opengl opengl.gl opengl.capabilities combinators images
+images.tesselation grouping specialized-arrays.float sequences math
+math.vectors math.matrices generalizations fry arrays namespaces
+system ;
IN: opengl.textures
+SYMBOL: non-power-of-2-textures?
+
+: check-extensions ( -- )
+ #! ATI frglx driver doesn't implement GL_ARB_texture_non_power_of_two properly.
+ #! See thread 'Linux font display problem' April 2009 on Factor-talk
+ gl-vendor "ATI Technologies Inc." = not os macosx? or [
+ "2.0" { "GL_ARB_texture_non_power_of_two" }
+ has-gl-version-or-extensions?
+ non-power-of-2-textures? set
+ ] when ;
+
: gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
: delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
+M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
+M: LA component-order>format drop GL_LUMINANCE_ALPHA GL_UNSIGNED_BYTE ;
+M: L component-order>format drop GL_LUMINANCE GL_UNSIGNED_BYTE ;
+
+SLOT: display-list
-GENERIC: draw-texture ( texture -- )
+: draw-texture ( texture -- ) display-list>> [ glCallList ] when* ;
GENERIC: draw-scaled-texture ( dim texture -- )
<PRIVATE
-TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
-
-: repeat-last ( seq n -- seq' )
- over peek pad-tail concat ;
-
-: power-of-2-bitmap ( rows dim size -- bitmap dim )
- '[
- first2
- [ [ _ ] dip '[ _ group _ repeat-last ] map ]
- [ repeat-last ]
- bi*
- ] keep ;
+TUPLE: single-texture image dim loc texture-coords texture display-list disposed ;
-: image-rows ( image -- rows )
- [ bitmap>> ]
- [ dim>> first ]
- [ component-order>> bytes-per-pixel ]
- tri * group ; inline
-
-: power-of-2-image ( image -- image )
- dup dim>> [ 0 = ] all? [
- clone dup
- [ image-rows ]
- [ dim>> [ next-power-of-2 ] map ]
- [ component-order>> bytes-per-pixel ] tri
- power-of-2-bitmap
- [ >>bitmap ] [ >>dim ] bi*
+: adjust-texture-dim ( dim -- dim' )
+ non-power-of-2-textures? get [
+ [ next-power-of-2 ] map
] unless ;
-:: make-texture ( image -- id )
+: (tex-image) ( image bitmap -- )
+ [
+ [ GL_TEXTURE_2D 0 GL_RGBA ] dip
+ [ dim>> adjust-texture-dim first2 0 ]
+ [ component-order>> component-order>format ] bi
+ ] dip
+ glTexImage2D ;
+
+: (tex-sub-image) ( image -- )
+ [ GL_TEXTURE_2D 0 0 0 ] dip
+ [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
+ glTexSubImage2D ;
+
+: make-texture ( image -- id )
+ #! We use glTexSubImage2D to work around the power of 2 texture size
+ #! limitation
gen-texture [
GL_TEXTURE_BIT [
GL_TEXTURE_2D swap glBindTexture
- GL_TEXTURE_2D
- 0
- GL_RGBA
- image dim>> first2
- 0
- image component-order>> component-order>format
- image bitmap>>
- glTexImage2D
+ non-power-of-2-textures? get
+ [ dup bitmap>> (tex-image) ]
+ [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if
] do-attribs
] keep ;
: init-texture ( -- )
- GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
- GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
+ GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri
+ GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ;
: draw-textured-rect ( dim texture -- )
[
- (draw-textured-rect)
- GL_TEXTURE_2D 0 glBindTexture
+ [ image>> has-alpha? [ GL_BLEND glDisable ] unless ]
+ [ (draw-textured-rect) GL_TEXTURE_2D 0 glBindTexture ]
+ [ image>> has-alpha? [ GL_BLEND glEnable ] unless ]
+ tri
] with-texturing ;
-: texture-coords ( dim -- coords )
- [ dup next-power-of-2 /f ] map
- { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } [ v* ] with map
- float-array{ } join ;
+: texture-coords ( texture -- coords )
+ [ [ dim>> ] [ image>> dim>> adjust-texture-dim ] bi v/ ]
+ [
+ image>> upside-down?>>
+ { { 0 1 } { 1 1 } { 1 0 } { 0 0 } }
+ { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } ?
+ ] bi
+ [ v* ] with map float-array{ } join ;
: make-texture-display-list ( texture -- dlist )
GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
: <single-texture> ( image loc -- texture )
- single-texture new swap >>loc
- swap
- [ dim>> >>dim ] keep
- [ dim>> product 0 = ] keep '[
- _
- [ dim>> texture-coords >>texture-coords ]
- [ power-of-2-image make-texture >>texture ] bi
+ single-texture new swap >>loc swap [ >>image ] [ dim>> >>dim ] bi
+ dup image>> dim>> product 0 = [
+ dup texture-coords >>texture-coords
+ dup image>> make-texture >>texture
dup make-texture-display-list >>display-list
] unless ;
[ texture>> [ delete-texture ] when* ]
[ display-list>> [ delete-dlist ] when* ] bi ;
-M: single-texture draw-texture display-list>> [ glCallList ] when* ;
-
M: single-texture draw-scaled-texture
dup texture>> [ draw-textured-rect ] [ 2drop ] if ;
TUPLE: multi-texture grid display-list loc disposed ;
: image-locs ( image-grid -- loc-grid )
- [ first [ dim>> first ] map ] [ 0 <column> [ dim>> second ] map ] bi
+ [ first [ dim>> first ] map ] [ [ first dim>> second ] map ] bi
[ 0 [ + ] accumulate nip ] bi@
cross-zip flip ;
: draw-textured-grid ( grid -- )
[ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
+: grid-has-alpha? ( grid -- ? )
+ first first image>> has-alpha? ;
+
: make-textured-grid-display-list ( grid -- dlist )
GL_COMPILE [
[
- [
- [
- [ dim>> ] keep (draw-textured-rect)
- ] each
- ] each
+ [ grid-has-alpha? [ GL_BLEND glDisable ] unless ]
+ [ [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ]
+ [ grid-has-alpha? [ GL_BLEND glEnable ] unless ] tri
GL_TEXTURE_2D 0 glBindTexture
] with-texturing
] make-dlist ;
f multi-texture boa
] with-destructors ;
-M: multi-texture draw-texture display-list>> [ glCallList ] when* ;
-
M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
-CONSTANT: max-texture-size { 256 256 }
+CONSTANT: max-texture-size { 512 512 }
PRIVATE>
: <texture> ( image loc -- texture )
over dim>> max-texture-size [ <= ] 2all?
[ <single-texture> ]
- [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
\ No newline at end of file
+ [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays assocs byte-arrays io
io.binary io.streams.string kernel math math.parser namespaces
-make parser prettyprint quotations sequences strings vectors
+make parser quotations sequences strings vectors
words macros math.functions math.bitwise fry generalizations
combinators.smart io.streams.byte-array io.encodings.binary
math.vectors combinators multiline endian ;
pango_layout_get_line_readonly ( PangoLayout* layout, int line ) ;
FUNCTION: void
-pango_layout_line_index_to_x ( PangoLayoutLine* line, int index_, gboolean trailing, int* x_pos ) ;
+pango_layout_line_index_to_x ( PangoLayoutLine* line, int index_, uint trailing, int* x_pos ) ;
FUNCTION: gboolean
pango_layout_line_x_to_index ( PangoLayoutLine* line, int x_pos, int* index_, int* trailing ) ;
: line-offset>x ( layout n -- x )
#! n is an index into the UTF8 encoding of the text
[ drop first-line ] [ swap string>> >utf8-index ] 2bi
- f 0 <int> [ pango_layout_line_index_to_x ] keep
+ 0 0 <int> [ pango_layout_line_index_to_x ] keep
*int pango>float ;
: x>line-offset ( layout x -- n )
: cached-line ( font string -- line )
cached-layout layout>> first-line ;
-[ <cache-assoc> cached-layouts set-global ] "pango.layouts" add-init-hook
\ No newline at end of file
+[ <cache-assoc> cached-layouts set-global ] "pango.layouts" add-init-hook
: pprint-prefix ( word quot -- )
<block swap pprint-word call block> ; inline
+M: parsing-word pprint*
+ \ POSTPONE: [ pprint-word ] pprint-prefix ;
+
M: word pprint*
- dup parsing-word? [
- \ POSTPONE: [ pprint-word ] pprint-prefix
- ] [
- {
- [ "break-before" word-prop line-break ]
- [ pprint-word ]
- [ ?start-group ]
- [ ?end-group ]
- [ "break-after" word-prop line-break ]
- } cleave
- ] if ;
+ [ pprint-word ] [ ?start-group ] [ ?end-group ] tri ;
+
+M: method-body pprint*
+ <block
+ \ M\ pprint-word
+ [ "method-class" word-prop pprint-word ]
+ [ "method-generic" word-prop pprint-word ] bi
+ block> ;
M: real pprint* number>string text ;
M: compose pprint* pprint-object ;
M: wrapper pprint*
- dup wrapped>> word? [
- <block \ \ pprint-word wrapped>> pprint-word block>
- ] [
- pprint-object
- ] if ;
+ {
+ { [ dup wrapped>> method-body? ] [ wrapped>> pprint* ] }
+ { [ dup wrapped>> word? ] [ <block \ \ pprint-word wrapped>> pprint-word block> ] }
+ [ pprint-object ]
+ } cond ;
"string-layout-test" string-layout check-see
] unit-test
-! Define dummy words for the below...
-: <NSRect> ( a b c d -- e ) ;
-: <PixelFormat> ( -- fmt ) ;
-: send ( obj -- ) ;
-
-\ send soft "break-after" set-word-prop
-
-: final-soft-break-test ( -- str )
- {
- "USING: kernel sequences ;"
- "IN: prettyprint.tests"
- ": final-soft-break-layout ( class dim -- view )"
- " [ \"alloc\" send 0 0 ] dip first2 <NSRect>"
- " <PixelFormat> \"initWithFrame:pixelFormat:\" send"
- " dup 1 \"setPostsBoundsChangedNotifications:\" send"
- " dup 1 \"setPostsFrameChangedNotifications:\" send ;"
- } ;
-
-[ t ] [
- "final-soft-break-layout" final-soft-break-test check-see
-] unit-test
-
: narrow-test ( -- str )
{
"USING: arrays combinators continuations kernel sequences ;"
M: f generic-see-test-with-f ;
[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
- [ { POSTPONE: f generic-see-test-with-f } see ] with-string-writer
-] unit-test
-
-[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
- [ \ f \ generic-see-test-with-f method see ] with-string-writer
+ [ M\ f generic-see-test-with-f see ] with-string-writer
] unit-test
PREDICATE: predicate-see-test < integer even? ;
M: started-out-hustlin' ended-up-ballin' ; inline
[ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [
- [ { started-out-hustlin' ended-up-ballin' } see ] with-string-writer
+ [ M\ started-out-hustlin' ended-up-ballin' see ] with-string-writer
] unit-test
TUPLE: concatenation first second ;
: <concatenation> ( seq -- concatenation )
- [ epsilon ] [ unclip [ concatenation boa ] reduce ] if-empty ;
+ [ epsilon ] [ [ ] [ concatenation boa ] map-reduce ] if-empty ;
TUPLE: alternation first second ;
: <alternation> ( seq -- alternation )
- unclip [ alternation boa ] reduce ;
+ [ ] [ alternation boa ] map-reduce ;
TUPLE: star term ;
C: <star> star
[ condition-states ] 2dip
'[ _ _ add-todo-state ] each ;
+: ensure-state ( key table -- )
+ 2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ; inline
+
:: new-transitions ( nfa dfa new-states visited-states -- nfa dfa )
new-states [ nfa dfa ] [
pop :> state
- state dfa transitions>> maybe-initialize-key
+ state dfa transitions>> ensure-state
state nfa find-transitions
[| trans |
state trans nfa find-closure :> new-state
{ CHAR: s dotall }
} ;
+ERROR: nonexistent-option name ;
+
: ch>option ( ch -- singleton )
- options-assoc at ;
+ dup options-assoc at [ ] [ nonexistent-option ] ?if ;
: option>ch ( option -- string )
options-assoc value-at ;
H{ } clone >>transitions
H{ } clone >>final-states ;
-: maybe-initialize-key ( key hashtable -- )
- ! Why do we have to do this?
- 2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ;
-
:: (set-transition) ( from to obj hash -- )
- to condition? [ to hash maybe-initialize-key ] unless
from hash at
[ [ to obj ] dip set-at ]
[ to obj associate from hash set-at ] if* ;
transitions>> (set-transition) ;
:: (add-transition) ( from to obj hash -- )
- to hash maybe-initialize-key
from hash at
[ [ to obj ] dip push-at ]
[ to 1vector obj associate from hash set-at ] if* ;
HELP: see
{ $values { "defspec" "a definition specifier" } }
-{ $contract "Prettyprints a definition." } ;
+{ $contract "Prettyprints a definition." }
+{ $examples
+ "A word:" { $code "\\ append see" }
+ "A method:" { $code "USE: arrays" "M\\ array length see" }
+ "A help article:" { $code "USE: help.topics" "\"help\" >link see" }
+} ;
HELP: see-methods
{ $values { "word" "a " { $link generic } " or a " { $link class } } }
--- /dev/null
+IN: see.tests
+USING: see tools.test io.streams.string math ;
+
+CONSTANT: test-const 10
+[ "IN: see.tests\nCONSTANT: test-const 10 inline\n" ]
+[ [ \ test-const see ] with-string-writer ] unit-test
+
+ALIAS: test-alias +
+
+[ "USING: math ;\nIN: see.tests\nALIAS: test-alias + inline\n" ]
+[ [ \ test-alias see ] with-string-writer ] unit-test
io.streams.string io.styles kernel make namespaces prettyprint
prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections sequences sets sorting strings summary
-words words.symbol ;
+words words.symbol words.constant words.alias ;
IN: see
GENERIC: synopsis* ( defspec -- )
: comment. ( text -- )
H{ { font-style italic } } styled-text ;
+GENERIC: print-stack-effect? ( word -- ? )
+
+M: parsing-word print-stack-effect? drop f ;
+M: symbol print-stack-effect? drop f ;
+M: constant print-stack-effect? drop f ;
+M: alias print-stack-effect? drop f ;
+M: word print-stack-effect? drop t ;
+
: stack-effect. ( word -- )
- [ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and
+ [ print-stack-effect? ] [ stack-effect ] bi and
[ effect>string comment. ] when* ;
<PRIVATE
[ stack-effect. ]
} cleave ;
-M: method-spec synopsis*
- first2 method synopsis* ;
-
M: method-body synopsis*
[ definer. ]
[ "method-class" word-prop pprint-word ]
block>
] with-use ;
-M: method-spec see*
- first2 method see* ;
-
GENERIC: see-class* ( word -- )
M: union-class see-class*
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: functors kernel math.order sequences sorting ;
+IN: sorting.functor
+
+FUNCTOR: define-sorting ( NAME QUOT -- )
+
+NAME<=> DEFINES ${NAME}<=>
+NAME>=< DEFINES ${NAME}>=<
+
+WHERE
+
+: NAME<=> ( obj1 obj2 -- <=> ) QUOT bi@ <=> ;
+: NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ;
+
+;FUNCTOR
}
{ $description "Compares two objects using the " { $link human<=> } " word and inverts the result." } ;
-HELP: human-compare
-{ $values
- { "obj1" object } { "obj2" object } { "quot" quotation }
- { "<=>" "an ordering specifier" }
-}
-{ $description "Compares the results of applying the quotation to both objects via <=>." } ;
-
-HELP: human-sort
-{ $values
- { "seq" sequence }
- { "seq'" sequence }
-}
-{ $description "Sorts a sequence of objects by comparing the magnitude of any integers in the input string using the <=> word." } ;
-
-HELP: human-sort-keys
-{ $values
- { "seq" "an alist" }
- { "sortedseq" "a new sorted sequence" }
-}
-{ $description "Sorts the elements comparing first elements of pairs using the " { $link human<=> } " word." } ;
-
-HELP: human-sort-values
-{ $values
- { "seq" "an alist" }
- { "sortedseq" "a new sorted sequence" }
-}
-{ $description "Sorts the elements comparing second elements of pairs using the " { $link human<=> } " word." } ;
-
-{ <=> >=< human-compare human-sort human-sort-keys human-sort-values } related-words
-
ARTICLE: "sorting.human" "Human-friendly sorting"
"The " { $vocab-link "sorting.human" } " vocabulary sorts by numbers as a human would -- by comparing their magnitudes -- rather than in a lexicographic way. For example, sorting a1, a10, a03, a2 with human sort returns a1, a2, a03, a10, while sorting with natural sort returns a03, a1, a10, a2." $nl
"Comparing two objects:"
{ $subsection human<=> }
{ $subsection human>=< }
-{ $subsection human-compare }
-"Sort a sequence:"
-{ $subsection human-sort }
-{ $subsection human-sort-keys }
-{ $subsection human-sort-values }
"Splitting a string into substrings and integers:"
{ $subsection find-numbers } ;
-USING: sorting.human tools.test ;
+USING: sorting.human tools.test sorting.slots ;
IN: sorting.human.tests
-\ human-sort must-infer
-
-[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } human-sort ] unit-test
+[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } { human<=> } sort-by ] unit-test
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: peg.ebnf math.parser kernel assocs sorting fry
-math.order sequences ascii splitting.monotonic ;
+USING: math.parser peg.ebnf sorting.functor ;
IN: sorting.human
: find-numbers ( string -- seq )
[EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ;
-: human<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ;
-
-: human>=< ( obj1 obj2 -- >=< ) human<=> invert-comparison ; inline
-
-: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ; inline
-
-: human-sort ( seq -- seq' ) [ human<=> ] sort ;
-
-: human-sort-keys ( seq -- sortedseq )
- [ [ first ] human-compare ] sort ;
-
-: human-sort-values ( seq -- sortedseq )
- [ [ second ] human-compare ] sort ;
+<< "human" [ find-numbers ] define-sorting >>
HELP: sort-by-slots
{ $values
{ "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" }
- { "seq'" sequence }
+ { "sortedseq" sequence }
}
{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." }
{ $examples
}
{ $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ;
+HELP: sort-by
+{ $values
+ { "seq" sequence } { "sort-seq" "a sequence of comparators" }
+ { "sortedseq" sequence }
+}
+{ $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ;
+
ARTICLE: "sorting.slots" "Sorting by slots"
"The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl
"Comparing two objects by a sequence of slots:"
{ $subsection compare-slots }
-"Sorting a sequence by a sequence of slots:"
-{ $subsection sort-by-slots } ;
+"Sorting a sequence of tuples by a slot/comparator pairs:"
+{ $subsection sort-by-slots }
+"Sorting a sequence by a sequence of comparators:"
+{ $subsection sort-by } ;
ABOUT: "sorting.slots"
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math.order sorting.slots tools.test
-sorting.human arrays sequences kernel assocs multiline ;
+sorting.human arrays sequences kernel assocs multiline
+sorting.functor ;
IN: sorting.literals.tests
TUPLE: sort-test a b c tuple2 ;
[ { } ]
[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test
+[ { } ]
+[ { } { } sort-by-slots ] unit-test
+
[
{
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
} { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map
] unit-test
+
+
+[ { "a" "b" "c" } ] [ { "b" "c" "a" } { <=> <=> } sort-by ] unit-test
+[ { "b" "c" "a" } ] [ { "b" "c" "a" } { } sort-by ] unit-test
+
+<< "length-test" [ length ] define-sorting >>
+
+[ { { 1 } { 1 2 3 } { 1 3 2 } { 3 2 1 } } ]
+[
+ { { 3 2 1 } { 1 2 3 } { 1 3 2 } { 1 } }
+ { length-test<=> <=> } sort-by
+] unit-test
<PRIVATE
+: short-circuit-comparator ( obj1 obj2 word -- comparator/? )
+ execute dup +eq+ eq? [ drop f ] when ; inline
+
: slot-comparator ( seq -- quot )
[
but-last-slice
[ '[ [ _ execute ] bi@ ] ] map concat
] [
peek
- '[ @ _ execute dup +eq+ eq? [ drop f ] when ]
+ '[ @ _ short-circuit-comparator ]
] bi ;
PRIVATE>
#! sort-spec: { accessors comparator }
[ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
-: sort-by-slots ( seq sort-specs -- seq' )
- '[ _ compare-slots ] sort ;
+MACRO: sort-by-slots ( sort-specs -- quot )
+ '[ [ _ compare-slots ] sort ] ;
+
+MACRO: compare-seq ( seq -- quot )
+ [ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ;
+
+MACRO: sort-by ( sort-seq -- quot )
+ '[ [ _ compare-seq ] sort ] ;
+
+MACRO: sort-keys-by ( sort-seq -- quot )
+ '[ [ first ] bi@ _ compare-seq ] sort ;
+
+MACRO: sort-values-by ( sort-seq -- quot )
+ '[ [ second ] bi@ _ compare-seq ] sort ;
MACRO: split-by-slots ( accessor-seqs -- quot )
[ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test sorting.title sorting.slots ;
+IN: sorting.title.tests
+
+: sort-me ( -- seq )
+ {
+ "The Beatles"
+ "A river runs through it"
+ "Another"
+ "la vida loca"
+ "Basketball"
+ "racquetball"
+ "Los Fujis"
+ "los Fujis"
+ "La cucaracha"
+ "a day to remember"
+ "of mice and men"
+ "on belay"
+ "for the horde"
+ } ;
+[
+ {
+ "Another"
+ "Basketball"
+ "The Beatles"
+ "La cucaracha"
+ "a day to remember"
+ "for the horde"
+ "Los Fujis"
+ "los Fujis"
+ "of mice and men"
+ "on belay"
+ "racquetball"
+ "A river runs through it"
+ "la vida loca"
+ }
+] [
+ sort-me { title<=> } sort-by
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sorting.functor regexp kernel accessors sequences
+unicode.case ;
+IN: sorting.title
+
+<< "title" [ >lower dup R/ ^(the|a|an|el|la|los|las|il) / first-match [ to>> tail-slice ] when* ] define-sorting >>
\ fflush { alien } { } define-primitive
+\ fseek { alien integer integer } { } define-primitive
+
\ fclose { alien } { } define-primitive
\ <wrapper> { object } { wrapper } define-primitive
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors arrays kernel kernel.private combinators.private
-words sequences generic math math.order namespaces make quotations assocs
-combinators combinators.short-circuit classes.tuple
+words sequences generic math math.order namespaces make quotations
+assocs combinators combinators.short-circuit classes.tuple
classes.tuple.private effects summary hashtables classes generic sets
definitions generic.standard slots.private continuations locals
-generalizations stack-checker.backend stack-checker.state
-stack-checker.visitor stack-checker.errors stack-checker.values
-stack-checker.recursive-state ;
+sequences.private generalizations stack-checker.backend
+stack-checker.state stack-checker.visitor stack-checker.errors
+stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.transforms
: give-up-transform ( word -- )
] [ drop f ] if
] 1 define-transform
-! Membership testing
-CONSTANT: bit-member-max 256
+! Fast at for integer maps
+CONSTANT: lookup-table-at-max 256
-: bit-member? ( seq -- ? )
+: lookup-table-at? ( assoc -- ? )
#! Can we use a fast byte array test here?
{
- [ length 4 > ]
+ [ assoc-size 4 > ]
+ [ values [ ] all? ]
+ [ keys [ integer? ] all? ]
+ [ keys [ 0 lookup-table-at-max between? ] all? ]
+ } 1&& ;
+
+: lookup-table-seq ( assoc -- table )
+ [ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
+
+: lookup-table-quot ( seq -- newquot )
+ lookup-table-seq
+ '[
+ _ over integer? [
+ 2dup bounds-check? [
+ nth-unsafe dup >boolean
+ ] [ 2drop f f ] if
+ ] [ 2drop f f ] if
+ ] ;
+
+: fast-lookup-table-at? ( assoc -- ? )
+ values {
[ [ integer? ] all? ]
- [ [ 0 bit-member-max between? ] any? ]
+ [ [ 0 254 between? ] all? ]
} 1&& ;
-: bit-member-seq ( seq -- flags )
- [ supremum 1+ ] keep '[ _ member? 1 0 ? ] B{ } map-as ;
+: fast-lookup-table-seq ( assoc -- table )
+ lookup-table-seq [ 255 or ] B{ } map-as ;
-: bit-member-quot ( seq -- newquot )
- bit-member-seq
+: fast-lookup-table-quot ( seq -- newquot )
+ fast-lookup-table-seq
'[
- _ {
- { [ over fixnum? ] [ ?nth 1 eq? ] }
- { [ over bignum? ] [ ?nth 1 eq? ] }
- [ 2drop f ]
- } cond
+ _ over integer? [
+ 2dup bounds-check? [
+ nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
+ ] [ 2drop f f ] if
+ ] [ 2drop f f ] if
] ;
-: member-quot ( seq -- newquot )
- dup bit-member? [
- bit-member-quot
- ] [
- dup length 4 <= [
- [ drop f ] swap
- [ literalize [ t ] ] { } map>assoc linear-case-quot
+: at-quot ( assoc -- quot )
+ dup lookup-table-at? [
+ dup fast-lookup-table-at? [
+ fast-lookup-table-quot
] [
- unique [ key? ] curry
+ lookup-table-quot
] if
+ ] [ drop f ] if ;
+
+\ at* [ at-quot ] 1 define-transform
+
+! Membership testing
+: member-quot ( seq -- newquot )
+ dup length 4 <= [
+ [ drop f ] swap
+ [ literalize [ t ] ] { } map>assoc linear-case-quot
+ ] [
+ unique [ key? ] curry
] if ;
\ member? [
\ shuffle [
shuffle-mapping nths-quot
-] 1 define-transform
\ No newline at end of file
+] 1 define-transform
M: string blah-generic ;
-{ string blah-generic } watch
+[ ] [ M\ string blah-generic watch ] unit-test
[ "hi" ] [ "hi" blah-generic ] unit-test
f "unannotated-def" set-word-prop
] [ drop ] if ;
-M: method-spec reset
- first2 method reset ;
-
ERROR: cannot-annotate-twice word ;
<PRIVATE
cannot-annotate-twice
] when ;
-: method-spec>word ( obj -- word )
- dup method-spec? [ first2 method ] when ;
-
: save-unannotated-def ( word -- )
dup def>> "unannotated-def" set-word-prop ;
PRIVATE>
: annotate ( word quot -- )
- [ method-spec>word check-annotate-twice ] dip
+ [ check-annotate-twice ] dip
[ over save-unannotated-def (annotate) ] with-compilation-unit ;
<PRIVATE
M: word annotate-methods
annotate ;
-M: method-spec annotate-methods
- annotate ;
-
: breakpoint ( word -- )
[ add-breakpoint ] annotate-methods ;
io.directories io.directories.hierarchy io.backend quotations
io.launcher words.private tools.deploy.config
tools.deploy.config.editor bootstrap.image io.encodings.utf8
-destructors accessors ;
+destructors accessors hashtables ;
IN: tools.deploy.backend
: copy-vm ( executable bundle-name -- vm )
[ drop ] [ make-staging-image ] if ;
: make-deploy-config ( vocab -- file )
- [ deploy-config unparse-use ]
+ [ deploy-config vocab-roots get vocab-roots associate assoc-union unparse-use ]
[ "deploy-config-" prepend temp-file ] bi
[ utf8 set-file-contents ] keep ;
: create-app-dir ( vocab bundle-name -- vm )
[
- nip
- [ copy-dll ]
- [ copy-nib ]
- [ "Contents/Resources" append-path make-directories ]
- tri
+ nip {
+ [ copy-dll ]
+ [ copy-nib ]
+ [ "Contents/Resources" append-path make-directories ]
+ [ "Contents/Resources" copy-theme ]
+ } cleave
]
[ create-app-plist ]
[ "Contents/MacOS/" append-path copy-vm ] 2tri
"specializer"
"step-into"
"step-into?"
- "superclass"
+ ! UI needs this
+ ! "superclass"
"transform-n"
"transform-quot"
"tuple-dispatch-generic"
strip-prettyprint? [
{
- "break-before"
- "break-after"
"delimiter"
"flushable"
"foldable"
lexer-factory
print-use-hook
root-cache
- vocab-roots
vocabs:dictionary
vocabs:load-vocab-hook
word
: copy-dll ( bundle-name -- )
"resource:factor.dll" swap copy-file-into ;
-: copy-pango ( bundle-name -- )
- "resource:build-support/dlls.txt" ascii file-lines
- [ "resource:" prepend-path ] map
- swap copy-files-into ;
-
:: copy-vm ( executable bundle-name extension -- vm )
vm "." split1-last drop extension append
bundle-name executable ".exe" append append-path
: create-exe-dir ( vocab bundle-name -- vm )
dup copy-dll
deploy-ui? get [
- [ copy-pango ]
- [ "" copy-theme ]
- [ ".exe" copy-vm ] tri
+ [ "" copy-theme ] [ ".exe" copy-vm ] bi
] [ ".com" copy-vm ] if ;
M: winnt deploy*
tools.disassembler tools.test strings ;\r
\r
[ ] [ \ + disassemble ] unit-test\r
-[ ] [ { string pprint* } disassemble ] unit-test\r
+[ ] [ M\ string pprint* disassemble ] unit-test\r
M: word disassemble word-xt 2array disassemble ;
-M: method-spec disassemble first2 method disassemble ;
-
cpu x86?
"tools.disassembler.udis"
"tools.disassembler.gdb" ?
16 * >hex 8 CHAR: 0 pad-head write "h: " write ;
: >hex-digit ( digit -- str )
- >hex 2 CHAR: 0 pad-head " " append ;
+ >hex 2 CHAR: 0 pad-head ;
: >hex-digits ( bytes -- str )
- [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-tail ;
+ [ >hex-digit " " append ] { } map-as concat
+ 48 CHAR: \s pad-tail ;
: >ascii ( bytes -- str )
[ [ printable? ] keep CHAR: . ? ] "" map-as ;
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces opengl opengl.gl ;
+USING: kernel namespaces opengl opengl.gl fry ;
IN: ui.backend
SYMBOL: ui-backend
HOOK: offscreen-pixels ui-backend ( world -- alien w h )
: with-gl-context ( handle quot -- )
- swap [ select-gl-context call ] keep
- glFlush flush-gl-context gl-error ; inline
+ '[ select-gl-context @ ]
+ [ flush-gl-context gl-error ] bi ; inline
HOOK: (with-ui) ui-backend ( quot -- )
\ No newline at end of file
[ 0 0 ] dip dim>> first2 <CGRect> ;
: auto-position ( window loc -- )
+ #! Note: if this is the initial window, the length of the windows
+ #! vector should be 1, since (open-window) calls auto-position
+ #! after register-window.
dup { 0 0 } = [
drop
- windows get [ -> center ] [
- peek second window-loc>>
+ windows get length 1 <= [ -> center ] [
+ windows get peek second window-loc>>
dupd first2 <CGPoint> -> cascadeTopLeftFromPoint:
-> setFrameTopLeftPoint:
- ] if-empty
+ ] if
] [ first2 <CGPoint> -> setFrameTopLeftPoint: ] if ;
M: cocoa-ui-backend set-title ( string world -- )
world dim>> <FactorView> :> view
view world world>NSRect <ViewWindow> :> window
view -> release
- window world window-loc>> auto-position
world view register-window
+ window world window-loc>> auto-position
world window save-position
window install-window-delegate
view window <window-handle> world (>>handle)
! Initialization
{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
- [ 2drop dup view-dim swap window (>>dim) yield ]
+ [ 2drop [ window ] [ view-dim ] bi >>dim drop yield ]
}
{ "doCommandBySelector:" "void" { "id" "SEL" "SEL" }
! Copyright (C) 2005, 2006 Doug Coleman.
! Portions copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings arrays assocs ui
-ui.private ui.gadgets ui.gadgets.private ui.backend
-ui.clipboards ui.gadgets.worlds ui.gestures ui.event-loop io
-kernel math math.vectors namespaces make sequences strings
-vectors words windows.kernel32 windows.gdi32 windows.user32
-windows.opengl32 windows.messages windows.types windows.nt
-windows threads libc combinators fry combinators.short-circuit
-continuations command-line shuffle opengl ui.render ascii
-math.bitwise locals accessors math.rectangles math.order ascii
-calendar io.encodings.utf16n ;
+USING: alien alien.c-types alien.strings arrays assocs ui ui.private
+ui.gadgets ui.gadgets.private ui.backend ui.clipboards
+ui.gadgets.worlds ui.gestures ui.event-loop io kernel math
+math.vectors namespaces make sequences strings vectors words
+windows.kernel32 windows.gdi32 windows.user32 windows.opengl32
+windows.messages windows.types windows.offscreen windows.nt windows
+threads libc combinators fry combinators.short-circuit continuations
+command-line shuffle opengl ui.render ascii math.bitwise locals
+accessors math.rectangles math.order ascii calendar
+io.encodings.utf16n ;
IN: ui.backend.windows
SINGLETON: windows-ui-backend
style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
: make-RECT ( world -- RECT )
- [ window-loc>> dup ] [ dim>> ] bi v+
- "RECT" <c-object>
- over first over set-RECT-right
- swap second over set-RECT-bottom
- over first over set-RECT-left
- swap second over set-RECT-top ;
+ [ window-loc>> ] [ dim>> ] bi <RECT> ;
: default-position-RECT ( RECT -- )
dup get-RECT-dimensions [ 2drop ] 2dip
hWnd>> show-window ;
M: win-base select-gl-context ( handle -- )
- [ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f
+ [ hDC>> ] [ hRC>> ] bi wglMakeCurrent win32-error=0/f
GdiFlush drop ;
M: win-base flush-gl-context ( handle -- )
hDC>> SwapBuffers win32-error=0/f ;
-: (bitmap-info) ( dim -- BITMAPINFO )
- "BITMAPINFO" <c-object> [
- BITMAPINFO-bmiHeader {
- [ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
- [ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
- [ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
- [ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
- [ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
- [ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
- [ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
- [ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
- [ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
- [ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
- [ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
- } 2cleave
- ] keep ;
-
-: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits )
- f CreateCompatibleDC
- dup rot (bitmap-info) DIB_RGB_COLORS f <void*>
- [ f 0 CreateDIBSection ] keep *void*
- [ 2dup SelectObject drop ] dip ;
-
: setup-offscreen-gl ( dim -- hDC hRC hBitmap bits )
make-offscreen-dc-and-bitmap [
[ dup offscreen-pfd-dwFlags setup-pixel-format ]
! each pixel; it's left as zero
: (make-opaque) ( byte-array -- byte-array' )
- [ length 4 / ]
+ [ length 4 /i ]
[ '[ 255 swap 4 * 3 + _ set-nth ] each ]
[ ] tri ;
: (opaque-pixels) ( world -- pixels )
- [ handle>> bits>> ] [ dim>> first2 * 4 * ] bi
- memory>byte-array (make-opaque) ;
+ [ handle>> bits>> ] [ dim>> ] bi bitmap>byte-array (make-opaque) ;
M: windows-ui-backend offscreen-pixels ( world -- alien w h )
[ (opaque-pixels) ] [ dim>> first2 ] bi ;
[ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
utf8 encode dup length XChangeProperty drop ;
+: set-class ( dpy window -- )
+ XA_WM_CLASS XA_UTF8_STRING 8 PropModeReplace "Factor"
+ utf8 encode dup length XChangeProperty drop ;
+
M: x11-ui-backend set-title ( string world -- )
handle>> window>> swap
[ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
M: x11-ui-backend (open-window) ( world -- )
dup gadget-window
- handle>> window>> dup set-closable map-window ;
+ handle>> window>>
+ [ set-closable ] [ dpy get swap set-class ] [ map-window ] tri ;
M: x11-ui-backend raise-window* ( world -- )
handle>> [
- dpy get swap window>> XRaiseWindow drop
+ dpy get swap window>>
+ [ RevertToPointerRoot CurrentTime XSetInputFocus drop ]
+ [ XRaiseWindow drop ]
+ 2bi
] when* ;
M: x11-handle select-gl-context ( handle -- )
{ $description "Creates a new " { $link button } " derived from a " { $link <border-button> } " which calls the quotation every 100 milliseconds as long as the mouse button is held down." } ;
HELP: button-pen
-{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " gneeric words by delegating to an object in one of four slots which depend on the state of the button being drawn:"
+{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words by delegating to an object in one of four slots which depend on the state of the button being drawn:"
{ $list
{ { $snippet "plain" } " - the button is inactive" }
{ { $snippet "rollover" } " - the button is under the mouse" }
: scroll>caret ( editor -- )
dup graft-state>> second [
[
- [ caret-loc ] [ caret-dim { 1 0 } v+ ] bi <rect>
+ [ caret-loc ] [ caret-dim { 2 1 } v+ ] bi <rect>
] keep scroll>rect
] [ drop ] if ;
editor "selection" f {
{ T{ button-down f { S+ } 1 } extend-selection }
+ { T{ button-up f { S+ } 1 } com-copy-selection }
{ T{ drag } drag-selection }
{ gain-focus focus-editor }
{ lose-focus unfocus-editor }
CONSTANT: vertical { 0 1 }
TUPLE: gadget < rect
+id
pref-dim
parent
children
M: gadget equal? 2drop f ;
-M: gadget hashcode* drop gadget hashcode* ;
+M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;
M: gadget model-changed 2drop ;
: validate-line ( m gadget -- n )
control-value [ drop f ] [ length 1- min 0 max ] if-empty ;
+: valid-line? ( n gadget -- ? )
+ control-value length 1- 0 swap between? ;
+
: visible-line ( gadget quot -- n )
'[
[ clip get @ origin get [ second ] bi@ - ] dip
: pane-caret&mark ( pane -- caret mark )
[ caret>> ] [ mark>> ] bi ; inline
-: selected-children ( pane -- seq )
+: selected-subtree ( pane -- seq )
[ pane-caret&mark sort-pair ] keep gadget-subtree ;
M: pane gadget-selection? pane-caret&mark and ;
M: pane gadget-selection ( pane -- string/f )
- selected-children gadget-text ;
+ selected-subtree gadget-text ;
: init-prototype ( pane -- pane )
<shelf> +baseline+ >>align >>prototype ; inline
[ >>last-line ] [ 1 track-add ] bi
dup prepare-last-line ; inline
-GENERIC: draw-selection ( loc obj -- )
-
-: if-fits ( rect quot -- )
- [ clip get over contains-rect? ] dip [ drop ] if ; inline
-
-M: gadget draw-selection ( loc gadget -- )
- swap offset-rect [
- rect-bounds gl-fill-rect
- ] if-fits ;
-
-M: node draw-selection ( loc node -- )
- 2dup value>> swap offset-rect [
- drop 2dup
- [ value>> loc>> v+ ] keep
- children>> [ draw-selection ] with each
- ] if-fits 2drop ;
-
-M: pane draw-gadget*
+M: pane selected-children
dup gadget-selection? [
- [ selection-color>> gl-color ]
- [
- [ loc>> vneg ] keep selected-children
- [ draw-selection ] with each
- ] bi
- ] [ drop ] if ;
+ [ selected-subtree leaves ]
+ [ selection-color>> ]
+ bi
+ ] [ drop f f ] if ;
: scroll-pane ( pane -- )
dup scrolls?>> [ scroll>bottom ] [ drop ] if ;
{ $values { "gadget" gadget } { "scroller/f" { $maybe scroller } } }
{ $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link scroller } ". Outputs " { $link f } " if the gadget is not contained in a " { $link scroller } "." } ;
-HELP: scroller-value
+HELP: scroll-position
{ $values { "scroller" scroller } { "loc" "a pair of integers" } }
{ $description "Outputs the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ;
-{ scroller-value scroll scroll>bottom scroll>top scroll>rect } related-words
+{ scroll-position set-scroll-position scroll>bottom scroll>top scroll>rect } related-words
HELP: <scroller>
{ $values { "gadget" gadget } { "scroller" "a new " { $link scroller } } }
{ <viewport> <scroller> } related-words
-HELP: scroll
+HELP: set-scroll-position
{ $values { "scroller" scroller } { "value" "a pair of integers" } }
{ $description "Sets the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ;
{ $subsection scroller }
{ $subsection <scroller> }
"Getting and setting the scroll position:"
-{ $subsection scroller-value }
-{ $subsection scroll }
+{ $subsection scroll-position }
+{ $subsection set-scroll-position }
"Writing scrolling-aware gadgets:"
{ $subsection scroll>bottom }
{ $subsection scroll>top }
[ { 100 100 } ] [ "s" get viewport>> gadget-child pref-dim ] unit-test
- [ ] [ { 0 0 } "s" get scroll ] unit-test
+ [ ] [ { 0 0 } "s" get set-scroll-position ] unit-test
[ { 0 0 } ] [ "s" get model>> range-min-value ] unit-test
[ { 100 100 } ] [ "s" get model>> range-max-value ] unit-test
- [ ] [ { 10 20 } "s" get scroll ] unit-test
+ [ ] [ { 10 20 } "s" get set-scroll-position ] unit-test
[ { 10 20 } ] [ "s" get model>> range-value ] unit-test
drop
"g2" get scroll>gadget
"s" get layout
- "s" get scroller-value
+ "s" get scroll-position
] map [ { 0 0 } = ] all?
] unit-test
: scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
+: set-scroll-position ( value scroller -- )
+ [
+ viewport>> [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi
+ 4array flip
+ ] keep
+ 2dup control-value = [ 2drop ] [ set-control-value ] if ;
+
<PRIVATE
: do-mouse-scroll ( scroller -- )
M: viewport pref-dim* gadget-child pref-viewport-dim ;
-: scroll ( value scroller -- )
- [
- viewport>> [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi
- 4array flip
- ] keep
- 2dup control-value = [ 2drop ] [ set-control-value ] if ;
-
: (scroll>rect) ( rect scroller -- )
- [ [ loc>> ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
{
- [ scroller-value vneg offset-rect ]
+ [ scroll-position vneg offset-rect ]
[ viewport>> dim>> rect-min ]
+ [ viewport>> loc>> offset-rect ]
[ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ]
- [ scroller-value v+ ]
- [ scroll ]
+ [ scroll-position v+ ]
+ [ set-scroll-position ]
} cleave ;
: relative-scroll-rect ( rect gadget scroller -- newrect )
2&& ;
: (update-scroller) ( scroller -- )
- [ scroller-value ] keep scroll ;
+ [ scroll-position ] keep set-scroll-position ;
: (scroll>gadget) ( gadget scroller -- )
2dup swap child? [
] [ f >>follows (update-scroller) drop ] if ;
: (scroll>bottom) ( scroller -- )
- [ viewport>> gadget-child pref-dim { 0 1 } v* ] keep scroll ;
+ [ viewport>> gadget-child pref-dim { 0 1 } v* ] keep
+ set-scroll-position ;
GENERIC: update-scroller ( scroller follows -- )
--- /dev/null
+IN: ui.gadgets.search-tables.tests
+USING: ui.gadgets.search-tables sequences tools.test ;
+[ [ second ] <search-table> ] must-infer
: <search-field> ( model -- gadget )
horizontal search-field new-track
+ 0 >>fill
{ 5 5 } >>gap
+baseline+ >>align
swap <model-field> 10 >>min-cols >>field
: mouse-row ( table -- n )
[ hand-rel second ] keep y>line ;
+: if-mouse-row ( table true: ( table mouse-index -- ) false: ( table -- ) -- )
+ [ [ mouse-row ] keep 2dup valid-line? ]
+ [ ] [ '[ nip @ ] ] tri* if ; inline
+
: table-button-down ( table -- )
dup takes-focus?>> [ dup request-focus ] when
- dup control-value empty? [ drop ] [
- dup [ mouse-row ] keep validate-line
- [ >>mouse-index ] [ (select-row) ] bi
- ] if ;
+ [ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ;
PRIVATE>
[ 2drop ]
if ;
+: row-action? ( table -- ? )
+ [ [ mouse-row ] keep valid-line? ]
+ [ single-click?>> hand-click# get 2 = or ] bi and ;
+
<PRIVATE
: table-button-up ( table -- )
- dup single-click?>> hand-click# get 2 = or
- [ row-action ] [ update-selected-value ] if ;
+ dup row-action? [ row-action ] [ update-selected-value ] if ;
: select-row ( table n -- )
over validate-line
: next-page ( table -- )
1 prev/next-page ;
-: valid-row? ( row table -- ? )
- control-value length 1- 0 swap between? ;
-
-: if-mouse-row ( table true false -- )
- [ [ mouse-row ] keep 2dup valid-row? ]
- [ ] [ '[ nip @ ] ] tri* if ; inline
-
: show-mouse-help ( table -- )
[
swap
M: viewport focusable-child*
gadget-child ;
-: scroller-value ( scroller -- loc )
+: scroll-position ( scroller -- loc )
model>> range-value [ >integer ] map ;
M: viewport model-changed
[ relayout-1 ]
[
[ gadget-child ]
- [ scroller-value vneg ]
+ [ scroll-position vneg ]
[ constraint>> ]
tri v* >>loc drop
] bi ;
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs continuations kernel math models
-namespaces opengl sequences io combinators combinators.short-circuit
-fry math.vectors math.rectangles cache ui.gadgets ui.gestures
-ui.render ui.backend ui.gadgets.tracks ui.commands ;
+namespaces opengl opengl.textures sequences io combinators
+combinators.short-circuit fry math.vectors math.rectangles cache
+ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
+ui.commands ;
IN: ui.gadgets.worlds
TUPLE: world < track
: (draw-world) ( world -- )
dup handle>> [
+ check-extensions
{
[ init-gl ]
[ draw-gadget ]
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math.rectangles math.vectors namespaces kernel accessors
-combinators sequences opengl opengl.gl opengl.glu colors
+assocs combinators sequences opengl opengl.gl colors
colors.constants ui.gadgets ui.pens ;
IN: ui.render
dim>>
[ { 0 1 } v* viewport-translation set ]
[ [ { 0 0 } ] dip gl-viewport ]
- [ [ 0 ] dip first2 0 gluOrtho2D ] tri
+ [ [ 0 ] dip first2 0 1 -1 glOrtho ] tri
]
[ clip set ] bi
do-clip ;
GENERIC: draw-children ( gadget -- )
+! For gadget selection
+SYMBOL: selected-gadgets
+
+SYMBOL: selection-background
+
+GENERIC: selected-children ( gadget -- assoc/f selection-background )
+
+M: gadget selected-children drop f f ;
+
+! For text rendering
+SYMBOL: background
+
+SYMBOL: foreground
+
+GENERIC: gadget-background ( gadget -- color )
+
+M: gadget gadget-background dup interior>> pen-background ;
+
+GENERIC: gadget-foreground ( gadget -- color )
+
+M: gadget gadget-foreground dup interior>> pen-foreground ;
+
+<PRIVATE
+
+: draw-selection-background ( gadget -- )
+ selection-background get background set
+ selection-background get gl-color
+ [ { 0 0 } ] dip dim>> gl-fill-rect ;
+
+: draw-standard-background ( object -- )
+ dup interior>> dup [ draw-interior ] [ 2drop ] if ;
+
+: draw-background ( gadget -- )
+ origin get [
+ [
+ dup selected-gadgets get key?
+ [ draw-selection-background ]
+ [ draw-standard-background ] if
+ ] [ draw-gadget* ] bi
+ ] with-translation ;
+
+: draw-border ( object -- )
+ dup boundary>> dup [
+ origin get [ draw-boundary ] with-translation
+ ] [ 2drop ] if ;
+
+PRIVATE>
+
: (draw-gadget) ( gadget -- )
dup loc>> origin get v+ origin [
- [
- origin get [
- [ dup interior>> dup [ draw-interior ] [ 2drop ] if ]
- [ draw-gadget* ]
- bi
- ] with-translation
- ]
- [ draw-children ]
- [
- dup boundary>> dup [
- origin get [ draw-boundary ] with-translation
- ] [ 2drop ] if
- ] tri
+ [ draw-background ] [ draw-children ] [ draw-border ] tri
] with-variable ;
: >absolute ( rect -- rect )
[ [ (draw-gadget) ] with-clipping ]
} cond ;
-! For text rendering
-SYMBOL: background
-
-SYMBOL: foreground
-
-GENERIC: gadget-background ( gadget -- color )
-
-M: gadget gadget-background dup interior>> pen-background ;
-
-GENERIC: gadget-foreground ( gadget -- color )
-
-M: gadget gadget-foreground dup interior>> pen-foreground ;
-
M: gadget draw-children
- [ visible-children ]
- [ gadget-background ]
- [ gadget-foreground ] tri [
- [ foreground set ] when*
- [ background set ] when*
- [ draw-gadget ] each
- ] with-scope ;
+ dup children>> [
+ {
+ [ visible-children ]
+ [ selected-children ]
+ [ gadget-background ]
+ [ gadget-foreground ]
+ } cleave [
+
+ {
+ [ [ selected-gadgets set ] when* ]
+ [ [ selection-background set ] when* ]
+ [ [ background set ] when* ]
+ [ [ foreground set ] when* ]
+ } spread
+ [ draw-gadget ] each
+ ] with-scope
+ ] [ drop ] if ;
CONSTANT: selection-color T{ rgba f 0.8 0.8 1.0 1.0 }
SINGLETON: core-text-renderer
-M: core-text-renderer init-text-rendering
- <cache-assoc> >>text-handle drop ;
-
M: core-text-renderer string-dim
[ " " string-dim { 0 1 } v* ]
[ cached-line dim>> ]
cached-lines get purge-cache ;
: rendered-line ( font string -- texture )
- world get world-text-handle
- [ cached-line [ image>> ] [ loc>> ] bi <texture> ]
- 2cache ;
+ world get world-text-handle [
+ cached-line [ image>> ] [ loc>> ] bi <texture>
+ ] 2cache ;
M: core-text-renderer draw-string ( font string -- )
rendered-line draw-texture ;
SINGLETON: pango-renderer
-M: pango-renderer init-text-rendering
- <cache-assoc> >>text-handle drop ;
-
M: pango-renderer string-dim
[ " " string-dim { 0 1 } v* ]
[ cached-layout logical-rect>> dim>> [ >integer ] map ] if-empty ;
cached-layouts get purge-cache ;
: rendered-layout ( font string -- texture )
- world get world-text-handle
- [ cached-layout [ image>> ] [ text-position vneg ] bi <texture> ]
- 2cache ;
+ world get world-text-handle [
+ cached-layout [ image>> ] [ text-position vneg ] bi <texture>
+ ] 2cache ;
M: pango-renderer draw-string ( font string -- )
rendered-layout draw-texture ;
--- /dev/null
+UI text rendering implementation using cross-platform Pango library\r
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test ui.text fonts ;
+USING: tools.test ui.text fonts math accessors kernel sequences ;
IN: ui.text.tests
-[ 0.0 ] [ 0 sans-serif-font "aaa" offset>x ] unit-test
+[ t ] [ 0 sans-serif-font "aaa" offset>x zero? ] unit-test
+[ t ] [ 1 sans-serif-font "aaa" offset>x 0.0 > ] unit-test
+[ t ] [ 3 sans-serif-font "aaa" offset>x 0.0 > ] unit-test
+[ t ] [ 1 monospace-font "a" offset>x 0.0 > ] unit-test
+[ 0 ] [ 0 sans-serif-font "aaa" x>offset ] unit-test
+[ 3 ] [ 100 sans-serif-font "aaa" x>offset ] unit-test
+[ 0 ] [ 0 sans-serif-font "" x>offset ] unit-test
+
+[ t ] [
+ sans-serif-font "aaa" line-metrics
+ [ [ ascent>> ] [ descent>> ] bi + ] [ height>> ] bi =
+] unit-test
+
+[ f ] [ sans-serif-font "\0a" text-dim first zero? ] unit-test
+[ t ] [ sans-serif-font "" text-dim first zero? ] unit-test
+
+[ f ] [ sans-serif-font font-metrics height>> zero? ] unit-test
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays sequences math math.order opengl opengl.gl
-strings fonts colors accessors namespaces ui.gadgets.worlds ;
+USING: kernel arrays sequences math math.order cache opengl
+opengl.gl strings fonts colors accessors namespaces
+ui.gadgets.worlds ;
IN: ui.text
<PRIVATE
SYMBOL: font-renderer
-HOOK: init-text-rendering font-renderer ( world -- )
-
: world-text-handle ( world -- handle )
- dup text-handle>> [ dup init-text-rendering ] unless
+ dup text-handle>> [ <cache-assoc> >>text-handle ] unless
text-handle>> ;
HOOK: flush-layout-cache font-renderer ( -- )
M: selection draw-text draw-string ;
M: array draw-text
- GL_MODELVIEW [
+ [
[
[ draw-string ]
[ [ 0.0 ] 2dip string-height 0.0 glTranslated ] 2bi
"ui-backend" get [
{
{ [ os macosx? ] [ "core-text" ] }
- { [ os windows? ] [ "pango" ] }
+ { [ os windows? ] [ "uniscribe" ] }
{ [ os unix? ] [ "pango" ] }
} cond
] unless* "ui.text." prepend require
\ No newline at end of file
--- /dev/null
+Slava Pestov\r
--- /dev/null
+UI text rendering implementation using the MS Windows Uniscribe library\r
--- /dev/null
+unportable\r
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors assocs cache kernel math math.vectors sequences fonts\r
+namespaces opengl.textures ui.text ui.text.private ui.gadgets.worlds \r
+windows.uniscribe ;\r
+IN: ui.text.uniscribe\r
+\r
+SINGLETON: uniscribe-renderer\r
+\r
+M: uniscribe-renderer string-dim\r
+ [ " " string-dim { 0 1 } v* ]\r
+ [ cached-script-string size>> ] if-empty ;\r
+\r
+M: uniscribe-renderer flush-layout-cache\r
+ cached-script-strings get purge-cache ;\r
+\r
+: rendered-script-string ( font string -- texture )\r
+ world get world-text-handle\r
+ [ cached-script-string image>> { 0 0 } <texture> ]\r
+ 2cache ;\r
+\r
+M: uniscribe-renderer draw-string ( font string -- )\r
+ dup dup selection? [ string>> ] when empty?\r
+ [ 2drop ] [ rendered-script-string draw-texture ] if ;\r
+\r
+M: uniscribe-renderer x>offset ( x font string -- n )\r
+ [ 2drop 0 ] [\r
+ cached-script-string x>line-offset 0 = [ 1+ ] unless\r
+ ] if-empty ;\r
+\r
+M: uniscribe-renderer offset>x ( n font string -- x )\r
+ [ 2drop 0 ] [ cached-script-string line-offset>x ] if-empty ;\r
+\r
+M: uniscribe-renderer font-metrics ( font -- metrics )\r
+ " " cached-script-string metrics>> clone f >>width ;\r
+\r
+M: uniscribe-renderer line-metrics ( font string -- metrics )\r
+ [ " " line-metrics clone 0 >>width ]\r
+ [ cached-script-string metrics>> 50 >>width 10 >>cap-height 10 >>x-height ]\r
+ if-empty ;\r
+\r
+uniscribe-renderer font-renderer set-global\r
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: debugger help help.topics help.crossref help.home kernel
-models compiler.units assocs words vocabs accessors fry
-combinators.short-circuit namespaces sequences models
-models.history help.apropos combinators ui.commands ui.gadgets
-ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
-ui.gestures ui.gadgets.buttons ui.gadgets.packs
-ui.gadgets.editors ui.gadgets.labels ui.gadgets.status-bar
-ui.gadgets.glass ui.gadgets.borders ui.tools.common
-ui.tools.browser.popups ui ;
+USING: debugger help help.topics help.crossref help.home kernel models
+compiler.units assocs words vocabs accessors fry arrays
+combinators.short-circuit namespaces sequences models help.apropos
+combinators ui ui.commands ui.gadgets ui.gadgets.panes
+ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons
+ui.gadgets.packs ui.gadgets.editors ui.gadgets.labels
+ui.gadgets.status-bar ui.gadgets.glass ui.gadgets.borders ui.gadgets.viewports
+ui.tools.common ui.tools.browser.popups ui.tools.browser.history ;
IN: ui.tools.browser
-TUPLE: browser-gadget < tool pane scroller search-field popup ;
+TUPLE: browser-gadget < tool history pane scroller search-field popup ;
{ 650 400 } browser-gadget set-tool-dim
+M: browser-gadget history-value
+ [ control-value ] [ scroller>> scroll-position ]
+ bi 2array ;
+
+M: browser-gadget set-history-value
+ [ first2 ] dip
+ [ set-control-value ] [ scroller>> set-scroll-position ]
+ bi-curry bi* ;
+
: show-help ( link browser-gadget -- )
- [ >link ] [ model>> ] bi*
- [ [ add-recent ] [ add-history ] bi* ] [ set-model ] 2bi ;
+ [ >link ] dip
+ [ [ add-recent ] [ history>> add-history ] bi* ]
+ [ model>> set-model ]
+ 2bi ;
: <help-pane> ( browser-gadget -- gadget )
model>> [ '[ _ print-topic ] try ] <pane-control> ;
: <browser-gadget> ( link -- gadget )
vertical browser-gadget new-track
1 >>fill
- swap >link <history> >>model
+ swap >link <model> >>model
+ dup <history> >>history
dup <search-field> >>search-field
dup <browser-toolbar> { 3 3 } <border> { 1 0 } >>fill f track-add
dup <help-pane> >>pane
\ show-browser H{ { +nullary+ t } } define-command
-: com-back ( browser -- ) model>> go-back ;
+: com-back ( browser -- ) history>> go-back ;
-: com-forward ( browser -- ) model>> go-forward ;
+: com-forward ( browser -- ) history>> go-forward ;
: com-home ( browser -- ) "help.home" swap show-help ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: namespaces ui.tools.browser.history sequences tools.test
+accessors kernel ;
+IN: ui.tools.browser.history.tests
+
+TUPLE: dummy obj ;
+
+M: dummy history-value obj>> ;
+M: dummy set-history-value (>>obj) ;
+
+dummy new <history> "history" set
+
+"history" get add-history
+
+[ t ] [ "history" get back>> empty? ] unit-test
+[ t ] [ "history" get forward>> empty? ] unit-test
+
+"history" get add-history
+3 "history" get owner>> set-history-value
+
+[ t ] [ "history" get back>> empty? ] unit-test
+[ t ] [ "history" get forward>> empty? ] unit-test
+
+"history" get add-history
+4 "history" get owner>> set-history-value
+
+[ f ] [ "history" get back>> empty? ] unit-test
+[ t ] [ "history" get forward>> empty? ] unit-test
+
+"history" get go-back
+
+[ 3 ] [ "history" get owner>> history-value ] unit-test
+
+[ t ] [ "history" get back>> empty? ] unit-test
+[ f ] [ "history" get forward>> empty? ] unit-test
+
+"history" get go-forward
+
+[ 4 ] [ "history" get owner>> history-value ] unit-test
+
+[ f ] [ "history" get back>> empty? ] unit-test
+[ t ] [ "history" get forward>> empty? ] unit-test
+
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences locals ;
+IN: ui.tools.browser.history
+
+TUPLE: history owner back forward ;
+
+: <history> ( owner -- history )
+ V{ } clone V{ } clone history boa ;
+
+GENERIC: history-value ( object -- value )
+
+GENERIC: set-history-value ( value object -- )
+
+: (add-history) ( history to -- )
+ swap owner>> history-value dup [ swap push ] [ 2drop ] if ;
+
+:: go-back/forward ( history to from -- )
+ from empty? [
+ history to (add-history)
+ from pop history owner>> set-history-value
+ ] unless ;
+
+: go-back ( history -- )
+ dup [ forward>> ] [ back>> ] bi go-back/forward ;
+
+: go-forward ( history -- )
+ dup [ back>> ] [ forward>> ] bi go-back/forward ;
+
+: add-history ( history -- )
+ dup forward>> delete-all
+ dup back>> (add-history) ;
\ No newline at end of file
t >>selection-required?
t >>single-click?
30 >>min-cols
+ 10 >>min-rows
10 >>max-rows
dup '[ _ accept-completion ] >>action ;
ARTICLE: "ui-tools" "UI developer tools"
"The " { $vocab-link "ui.tools" } " vocabulary hierarchy implements a collection of simple developer tools."
-$nl
+{ $subsection "starting-ui-tools" }
"To take full advantage of the UI tools, you should be using a supported text editor. See " { $link "editor" } "."
$nl
"Common functionality:"
{ $subsection "ui-listener" }
{ $subsection "ui-browser" }
{ $subsection "ui-inspector" }
-{ $subsection "ui-profiler" }
+{ $subsection "ui.tools.profiler" }
{ $subsection "ui-walker" }
{ $subsection "ui.tools.deploy" }
"Platform-specific features:"
{ 0 1 } { 2 0 1 } { { "a" "b" "c" "d" } { "e" "f" "g" } { { "h" "i" } "j" } } gadgets-in-range
] unit-test
-[ { array children>> } forget ] with-compilation-unit
+[ M\ array children>> forget ] with-compilation-unit
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces make sequences kernel math arrays io
-ui.gadgets generic combinators ;
+ui.gadgets generic combinators fry sets ;
IN: ui.traverse
TUPLE: node value children ;
: gadget-at-path ( parent path -- gadget )
[ swap nth-gadget ] each ;
+
+GENERIC# leaves* 1 ( tree assoc -- )
+
+M: node leaves* [ children>> ] dip leaves* ;
+
+M: array leaves* '[ _ leaves* ] each ;
+
+M: gadget leaves* conjoin ;
+
+: leaves ( tree -- assoc ) H{ } clone [ leaves* ] keep ;
\ No newline at end of file
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs io kernel math models namespaces make dlists
deques sequences threads sequences words continuations init
-combinators hashtables concurrency.flags sets accessors calendar fry
-destructors ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.gadgets.tracks ui.gestures ui.backend ui.render ;
+combinators combinators.short-circuit hashtables concurrency.flags
+sets accessors calendar fry destructors ui.gadgets ui.gadgets.private
+ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render ;
IN: ui
<PRIVATE
gesture-queue [ send-queued-gesture notify-queued ] slurp-deque ;
: update-ui ( -- )
- [
- notify-queued
- layout-queued
- redraw-worlds
- send-queued-gestures
- ] [ ui-error ] recover ;
+ notify-queued
+ layout-queued
+ redraw-worlds
+ send-queued-gestures ;
SYMBOL: ui-thread
PRIVATE>
: find-window ( quot -- world )
- windows get values
- [ gadget-child swap call ] with find-last nip ; inline
+ [ windows get values ] dip '[ gadget-child @ ] find-last nip ; inline
: ui-running? ( -- ? )
\ ui-running get-global ;
<PRIVATE
: update-ui-loop ( -- )
- [ ui-running? ui-thread get-global self eq? and ]
- [ ui-notify-flag get lower-flag update-ui ]
- while ;
+ #! Note the logic: if update-ui fails, we open an error window
+ #! and run one iteration of update-ui. If that also fails, well,
+ #! the whole UI subsystem is broken so we exit out of the
+ #! update-ui-loop.
+ [ { [ ui-running? ] [ ui-thread get-global self eq? ] } 0&& ]
+ [
+ ui-notify-flag get lower-flag
+ [ update-ui ] [ ui-error update-ui ] recover
+ ] while ;
: start-ui-thread ( -- )
[ self ui-thread set-global update-ui-loop ]
: with-ui ( quot -- )
ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ;
-HOOK: beep ui-backend ( -- )
\ No newline at end of file
+HOOK: beep ui-backend ( -- )
[ "Lo" ] [ HEX: 3450 category ] unit-test
[ "Lo" ] [ HEX: 4DB5 category ] unit-test
[ "Cs" ] [ HEX: DD00 category ] unit-test
+[ t ] [ CHAR: \t blank? ] unit-test
+[ t ] [ CHAR: \s blank? ] unit-test
+[ t ] [ CHAR: \r blank? ] unit-test
+[ t ] [ CHAR: \n blank? ] unit-test
+[ f ] [ CHAR: a blank? ] unit-test
USING: unicode.categories.syntax sequences unicode.data ;
IN: unicode.categories
-CATEGORY: blank Zs Zl Zp | "\r\n" member? ;
+CATEGORY: blank Zs Zl Zp | "\r\n\t" member? ;
CATEGORY: letter Ll | "Other_Lowercase" property? ;
CATEGORY: LETTER Lu | "Other_Uppercase" property? ;
CATEGORY: Letter Lu Ll Lt Lm Lo Nl ;
USING: help.markup help.syntax strings ;
IN: unicode
-ARTICLE: "unicode" "Unicode"
+ARTICLE: "unicode" "Unicode support"
"The " { $vocab-link "unicode" } " vocabulary and its sub-vocabularies implement support for the Unicode 5.1 character set."
$nl
"The Unicode character set contains most of the world's writing systems. Unicode is intended as a replacement for, and is a superset of, such legacy character sets as ASCII, Latin1, MacRoman, and so on. Unicode characters are called " { $emphasis "code points" } "; Factor's " { $link "strings" } " are sequences of code points."
[ H{ { "text" "hello world" } } ] [ "text=hello+world" query>assoc ] unit-test
[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
+
+[ "a" ] [ { { "a" f } } assoc>query ] unit-test
+
+[ H{ { "a" f } } ] [ "a" query>assoc ] unit-test
\ No newline at end of file
] when*
] 2keep set-at ;
+: assoc-strings ( assoc -- assoc' )
+ [
+ {
+ { [ dup not ] [ ] }
+ { [ dup array? ] [ [ present ] map ] }
+ [ present 1array ]
+ } cond
+ ] assoc-map ;
+
PRIVATE>
: query>assoc ( query -- assoc )
: assoc>query ( assoc -- str )
[
- dup array? [ [ present ] map ] [ present 1array ] if
- ] assoc-map
- [
- [
+ assoc-strings [
[ url-encode ] dip
- [ url-encode "=" glue , ] with each
+ [ [ url-encode "=" glue , ] with each ] [ , ] if*
] assoc-each
] { } make "&" join ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel present prettyprint.custom prettyprint.backend urls ;
+USING: kernel present prettyprint.custom prettyprint.sections
+prettyprint.backend urls ;
IN: urls.prettyprint
-M: url pprint* dup present "URL\" " "\"" pprint-string ;
+M: url pprint*
+ \ URL" record-vocab
+ dup present "URL\" " "\"" pprint-string ;
} ;
HELP: ensure-port
-{ $values { "url" url } }
-{ $description "If the URL does not specify a port number, fill in the default for the URL's protocol. If the protocol is unknown, the port number is not changed." }
-{ $side-effects "url" }
+{ $values { "url" url } { "url'" url } }
+{ $description "If the URL does not specify a port number, create a new URL which is equal except the port number is set to the default for the URL's protocol. If the protocol is unknown, outputs an exact copy of the input URL." }
{ $examples
{ $example
"USING: accessors prettyprint urls ;"
IN: urls.tests
-USING: urls urls.private tools.test
+USING: urls urls.private tools.test prettyprint
arrays kernel assocs present accessors ;
CONSTANT: urls
}
"ftp://slava:secret@ftp.kernel.org/"
}
+ {
+ T{ url
+ { protocol "http" }
+ { host "foo.com" }
+ { path "/" }
+ { query H{ { "a" f } } }
+ }
+ "http://foo.com/?a"
+ }
}
urls [
[ "http://localhost/?foo=bar" >url ] unit-test
[ "/" ] [ "http://www.jedit.org" >url path>> ] unit-test
+
+[ "USING: urls ;\nURL\" foo\"" ] [ URL" foo" unparse-use ] unit-test
\ No newline at end of file
] [ protocol>> ] bi
secure-protocol? [ >secure-addr ] when ;
-: ensure-port ( url -- url )
- dup protocol>> '[ _ protocol-port or ] change-port ;
+: ensure-port ( url -- url' )
+ clone dup protocol>> '[ _ protocol-port or ] change-port ;
! Literal syntax
SYNTAX: URL" lexer get skip-blank parse-string >url parsed ;
IN: values\r
\r
ARTICLE: "values" "Global values"\r
-"Usually, dynamically scoped variables are sufficient for holding data which is not literal. But occasionally, for global information that's calculated just once, it's useful to use the word mechanism instead, and set the word to the appropriate value just once. The " { $vocab-link "values" } " vocabulary implements " { $emphasis "values" } ", which abstract over this concept. To create a new word as a value, use the following syntax:"\r
+"Usually, dynamically-scoped variables subsume global variables and are sufficient for holding global data. But occasionally, for global information that's calculated just once and must be accessed more rapidly than a dynamic variable lookup can provide, it's useful to use the word mechanism instead, and set a word to the appropriate value just once. The " { $vocab-link "values" } " vocabulary implements " { $emphasis "values" } ", which abstract over this concept. To create a new word as a value, use the following syntax:"\r
{ $subsection POSTPONE: VALUE: }\r
"To get the value, just call the word. The following words manipulate values:"\r
{ $subsection get-value }\r
--- /dev/null
+USING: assocs memoize locals kernel accessors init fonts math\r
+combinators windows windows.types windows.gdi32 ;\r
+IN: windows.fonts\r
+\r
+: windows-font-name ( string -- string' )\r
+ H{\r
+ { "sans-serif" "Tahoma" }\r
+ { "serif" "Times New Roman" }\r
+ { "monospace" "Courier New" }\r
+ } at-default ;\r
+ \r
+MEMO:: (cache-font) ( font -- HFONT )\r
+ font size>> neg ! nHeight\r
+ 0 0 0 ! nWidth, nEscapement, nOrientation\r
+ font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight\r
+ font italic?>> TRUE FALSE ? ! fdwItalic\r
+ FALSE ! fdwUnderline\r
+ FALSE ! fdWStrikeOut\r
+ DEFAULT_CHARSET ! fdwCharSet\r
+ OUT_OUTLINE_PRECIS ! fdwOutputPrecision\r
+ CLIP_DEFAULT_PRECIS ! fdwClipPrecision\r
+ DEFAULT_QUALITY ! fdwQuality\r
+ DEFAULT_PITCH ! fdwPitchAndFamily\r
+ font name>> windows-font-name\r
+ CreateFont\r
+ dup win32-error=0/f ;\r
+\r
+: cache-font ( font -- HFONT ) strip-font-colors (cache-font) ;\r
+\r
+[ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook\r
+\r
+: TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )\r
+ [ metrics new 0 >>width ] dip {\r
+ [ TEXTMETRICW-tmHeight >>height ]\r
+ [ TEXTMETRICW-tmAscent >>ascent ]\r
+ [ TEXTMETRICW-tmDescent >>descent ]\r
+ } cleave ;\r
-! FUNCTION: AbortDoc
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax kernel windows.types ;
+USING: alien alien.syntax alien.destructors kernel windows.types
+math.bitwise ;
IN: windows.gdi32
-! Stock Logical Objects
-CONSTANT: WHITE_BRUSH 0
-CONSTANT: LTGRAY_BRUSH 1
-CONSTANT: GRAY_BRUSH 2
-CONSTANT: DKGRAY_BRUSH 3
-CONSTANT: BLACK_BRUSH 4
-CONSTANT: NULL_BRUSH 5
-ALIAS: HOLLOW_BRUSH NULL_BRUSH
-CONSTANT: WHITE_PEN 6
-CONSTANT: BLACK_PEN 7
-CONSTANT: NULL_PEN 8
-CONSTANT: OEM_FIXED_FONT 10
-CONSTANT: ANSI_FIXED_FONT 11
-CONSTANT: ANSI_VAR_FONT 12
-CONSTANT: SYSTEM_FONT 13
+CONSTANT: BI_RGB 0
+CONSTANT: BI_RLE8 1
+CONSTANT: BI_RLE4 2
+CONSTANT: BI_BITFIELDS 3
+CONSTANT: BI_JPEG 4
+CONSTANT: BI_PNG 5
+CONSTANT: LF_FACESIZE 32
+CONSTANT: LF_FULLFACESIZE 64
+CONSTANT: CA_NEGATIVE 1
+CONSTANT: CA_LOG_FILTER 2
+CONSTANT: ILLUMINANT_DEVICE_DEFAULT 0
+CONSTANT: ILLUMINANT_A 1
+CONSTANT: ILLUMINANT_B 2
+CONSTANT: ILLUMINANT_C 3
+CONSTANT: ILLUMINANT_D50 4
+CONSTANT: ILLUMINANT_D55 5
+CONSTANT: ILLUMINANT_D65 6
+CONSTANT: ILLUMINANT_D75 7
+CONSTANT: ILLUMINANT_F2 8
+ALIAS: ILLUMINANT_MAX_INDEX ILLUMINANT_F2
+ALIAS: ILLUMINANT_TUNGSTEN ILLUMINANT_A
+ALIAS: ILLUMINANT_DAYLIGHT ILLUMINANT_C
+ALIAS: ILLUMINANT_FLUORESCENT ILLUMINANT_F2
+ALIAS: ILLUMINANT_NTSC ILLUMINANT_C
+CONSTANT: RGB_GAMMA_MIN 2500
+CONSTANT: RGB_GAMMA_MAX 65000
+CONSTANT: REFERENCE_WHITE_MIN 6000
+CONSTANT: REFERENCE_WHITE_MAX 10000
+CONSTANT: REFERENCE_BLACK_MIN 0
+CONSTANT: REFERENCE_BLACK_MAX 4000
+CONSTANT: COLOR_ADJ_MIN -100
+CONSTANT: COLOR_ADJ_MAX 100
+CONSTANT: CCHDEVICENAME 32
+CONSTANT: CCHFORMNAME 32
+CONSTANT: DI_COMPAT 4
+CONSTANT: DI_DEFAULTSIZE 8
+CONSTANT: DI_IMAGE 2
+CONSTANT: DI_MASK 1
+CONSTANT: DI_NORMAL 3
+CONSTANT: DI_APPBANDING 1
+CONSTANT: EMR_HEADER 1
+CONSTANT: EMR_POLYBEZIER 2
+CONSTANT: EMR_POLYGON 3
+CONSTANT: EMR_POLYLINE 4
+CONSTANT: EMR_POLYBEZIERTO 5
+CONSTANT: EMR_POLYLINETO 6
+CONSTANT: EMR_POLYPOLYLINE 7
+CONSTANT: EMR_POLYPOLYGON 8
+CONSTANT: EMR_SETWINDOWEXTEX 9
+CONSTANT: EMR_SETWINDOWORGEX 10
+CONSTANT: EMR_SETVIEWPORTEXTEX 11
+CONSTANT: EMR_SETVIEWPORTORGEX 12
+CONSTANT: EMR_SETBRUSHORGEX 13
+CONSTANT: EMR_EOF 14
+CONSTANT: EMR_SETPIXELV 15
+CONSTANT: EMR_SETMAPPERFLAGS 16
+CONSTANT: EMR_SETMAPMODE 17
+CONSTANT: EMR_SETBKMODE 18
+CONSTANT: EMR_SETPOLYFILLMODE 19
+CONSTANT: EMR_SETROP2 20
+CONSTANT: EMR_SETSTRETCHBLTMODE 21
+CONSTANT: EMR_SETTEXTALIGN 22
+CONSTANT: EMR_SETCOLORADJUSTMENT 23
+CONSTANT: EMR_SETTEXTCOLOR 24
+CONSTANT: EMR_SETBKCOLOR 25
+CONSTANT: EMR_OFFSETCLIPRGN 26
+CONSTANT: EMR_MOVETOEX 27
+CONSTANT: EMR_SETMETARGN 28
+CONSTANT: EMR_EXCLUDECLIPRECT 29
+CONSTANT: EMR_INTERSECTCLIPRECT 30
+CONSTANT: EMR_SCALEVIEWPORTEXTEX 31
+CONSTANT: EMR_SCALEWINDOWEXTEX 32
+CONSTANT: EMR_SAVEDC 33
+CONSTANT: EMR_RESTOREDC 34
+CONSTANT: EMR_SETWORLDTRANSFORM 35
+CONSTANT: EMR_MODIFYWORLDTRANSFORM 36
+CONSTANT: EMR_SELECTOBJECT 37
+CONSTANT: EMR_CREATEPEN 38
+CONSTANT: EMR_CREATEBRUSHINDIRECT 39
+CONSTANT: EMR_DELETEOBJECT 40
+CONSTANT: EMR_ANGLEARC 41
+CONSTANT: EMR_ELLIPSE 42
+CONSTANT: EMR_RECTANGLE 43
+CONSTANT: EMR_ROUNDRECT 44
+CONSTANT: EMR_ARC 45
+CONSTANT: EMR_CHORD 46
+CONSTANT: EMR_PIE 47
+CONSTANT: EMR_SELECTPALETTE 48
+CONSTANT: EMR_CREATEPALETTE 49
+CONSTANT: EMR_SETPALETTEENTRIES 50
+CONSTANT: EMR_RESIZEPALETTE 51
+CONSTANT: EMR_REALIZEPALETTE 52
+CONSTANT: EMR_EXTFLOODFILL 53
+CONSTANT: EMR_LINETO 54
+CONSTANT: EMR_ARCTO 55
+CONSTANT: EMR_POLYDRAW 56
+CONSTANT: EMR_SETARCDIRECTION 57
+CONSTANT: EMR_SETMITERLIMIT 58
+CONSTANT: EMR_BEGINPATH 59
+CONSTANT: EMR_ENDPATH 60
+CONSTANT: EMR_CLOSEFIGURE 61
+CONSTANT: EMR_FILLPATH 62
+CONSTANT: EMR_STROKEANDFILLPATH 63
+CONSTANT: EMR_STROKEPATH 64
+CONSTANT: EMR_FLATTENPATH 65
+CONSTANT: EMR_WIDENPATH 66
+CONSTANT: EMR_SELECTCLIPPATH 67
+CONSTANT: EMR_ABORTPATH 68
+CONSTANT: EMR_GDICOMMENT 70
+CONSTANT: EMR_FILLRGN 71
+CONSTANT: EMR_FRAMERGN 72
+CONSTANT: EMR_INVERTRGN 73
+CONSTANT: EMR_PAINTRGN 74
+CONSTANT: EMR_EXTSELECTCLIPRGN 75
+CONSTANT: EMR_BITBLT 76
+CONSTANT: EMR_STRETCHBLT 77
+CONSTANT: EMR_MASKBLT 78
+CONSTANT: EMR_PLGBLT 79
+CONSTANT: EMR_SETDIBITSTODEVICE 80
+CONSTANT: EMR_STRETCHDIBITS 81
+CONSTANT: EMR_EXTCREATEFONTINDIRECTW 82
+CONSTANT: EMR_EXTTEXTOUTA 83
+CONSTANT: EMR_EXTTEXTOUTW 84
+CONSTANT: EMR_POLYBEZIER16 85
+CONSTANT: EMR_POLYGON16 86
+CONSTANT: EMR_POLYLINE16 87
+CONSTANT: EMR_POLYBEZIERTO16 88
+CONSTANT: EMR_POLYLINETO16 89
+CONSTANT: EMR_POLYPOLYLINE16 90
+CONSTANT: EMR_POLYPOLYGON16 91
+CONSTANT: EMR_POLYDRAW16 92
+CONSTANT: EMR_CREATEMONOBRUSH 93
+CONSTANT: EMR_CREATEDIBPATTERNBRUSHPT 94
+CONSTANT: EMR_EXTCREATEPEN 95
+CONSTANT: EMR_POLYTEXTOUTA 96
+CONSTANT: EMR_POLYTEXTOUTW 97
+CONSTANT: EMR_SETICMMODE 98
+CONSTANT: EMR_CREATECOLORSPACE 99
+CONSTANT: EMR_SETCOLORSPACE 100
+CONSTANT: EMR_DELETECOLORSPACE 101
+CONSTANT: EMR_GLSRECORD 102
+CONSTANT: EMR_GLSBOUNDEDRECORD 103
+CONSTANT: EMR_PIXELFORMAT 104
+CONSTANT: ENHMETA_SIGNATURE 1179469088
+CONSTANT: EPS_SIGNATURE HEX: 46535045
+CONSTANT: FR_PRIVATE HEX: 10
+CONSTANT: FR_NOT_ENUM HEX: 20
+CONSTANT: META_SETBKCOLOR HEX: 201
+CONSTANT: META_SETBKMODE HEX: 102
+CONSTANT: META_SETMAPMODE HEX: 103
+CONSTANT: META_SETROP2 HEX: 104
+CONSTANT: META_SETRELABS HEX: 105
+CONSTANT: META_SETPOLYFILLMODE HEX: 106
+CONSTANT: META_SETSTRETCHBLTMODE HEX: 107
+CONSTANT: META_SETTEXTCHAREXTRA HEX: 108
+CONSTANT: META_SETTEXTCOLOR HEX: 209
+CONSTANT: META_SETTEXTJUSTIFICATION HEX: 20A
+CONSTANT: META_SETWINDOWORG HEX: 20B
+CONSTANT: META_SETWINDOWEXT HEX: 20C
+CONSTANT: META_SETVIEWPORTORG HEX: 20D
+CONSTANT: META_SETVIEWPORTEXT HEX: 20E
+CONSTANT: META_OFFSETWINDOWORG HEX: 20F
+CONSTANT: META_SCALEWINDOWEXT HEX: 410
+CONSTANT: META_OFFSETVIEWPORTORG HEX: 211
+CONSTANT: META_SCALEVIEWPORTEXT HEX: 412
+CONSTANT: META_LINETO HEX: 213
+CONSTANT: META_MOVETO HEX: 214
+CONSTANT: META_EXCLUDECLIPRECT HEX: 415
+CONSTANT: META_INTERSECTCLIPRECT HEX: 416
+CONSTANT: META_ARC HEX: 817
+CONSTANT: META_ELLIPSE HEX: 418
+CONSTANT: META_FLOODFILL HEX: 419
+CONSTANT: META_PIE HEX: 81A
+CONSTANT: META_RECTANGLE HEX: 41B
+CONSTANT: META_ROUNDRECT HEX: 61C
+CONSTANT: META_PATBLT HEX: 61D
+CONSTANT: META_SAVEDC HEX: 1E
+CONSTANT: META_SETPIXEL HEX: 41F
+CONSTANT: META_OFFSETCLIPRGN HEX: 220
+CONSTANT: META_TEXTOUT HEX: 521
+CONSTANT: META_BITBLT HEX: 922
+CONSTANT: META_STRETCHBLT HEX: b23
+CONSTANT: META_POLYGON HEX: 324
+CONSTANT: META_POLYLINE HEX: 325
+CONSTANT: META_ESCAPE HEX: 626
+CONSTANT: META_RESTOREDC HEX: 127
+CONSTANT: META_FILLREGION HEX: 228
+CONSTANT: META_FRAMEREGION HEX: 429
+CONSTANT: META_INVERTREGION HEX: 12A
+CONSTANT: META_PAINTREGION HEX: 12B
+CONSTANT: META_SELECTCLIPREGION HEX: 12C
+CONSTANT: META_SELECTOBJECT HEX: 12D
+CONSTANT: META_SETTEXTALIGN HEX: 12E
+CONSTANT: META_CHORD HEX: 830
+CONSTANT: META_SETMAPPERFLAGS HEX: 231
+CONSTANT: META_EXTTEXTOUT HEX: a32
+CONSTANT: META_SETDIBTODEV HEX: d33
+CONSTANT: META_SELECTPALETTE HEX: 234
+CONSTANT: META_REALIZEPALETTE HEX: 35
+CONSTANT: META_ANIMATEPALETTE HEX: 436
+CONSTANT: META_SETPALENTRIES HEX: 37
+CONSTANT: META_POLYPOLYGON HEX: 538
+CONSTANT: META_RESIZEPALETTE HEX: 139
+CONSTANT: META_DIBBITBLT HEX: 940
+CONSTANT: META_DIBSTRETCHBLT HEX: b41
+CONSTANT: META_DIBCREATEPATTERNBRUSH HEX: 142
+CONSTANT: META_STRETCHDIB HEX: f43
+CONSTANT: META_EXTFLOODFILL HEX: 548
+CONSTANT: META_DELETEOBJECT HEX: 1f0
+CONSTANT: META_CREATEPALETTE HEX: f7
+CONSTANT: META_CREATEPATTERNBRUSH HEX: 1F9
+CONSTANT: META_CREATEPENINDIRECT HEX: 2FA
+CONSTANT: META_CREATEFONTINDIRECT HEX: 2FB
+CONSTANT: META_CREATEBRUSHINDIRECT HEX: 2FC
+CONSTANT: META_CREATEREGION HEX: 6FF
+CONSTANT: ELF_VENDOR_SIZE 4
+CONSTANT: ELF_VERSION 0
+CONSTANT: ELF_CULTURE_LATIN 0
+CONSTANT: PFD_TYPE_RGBA 0
+CONSTANT: PFD_TYPE_COLORINDEX 1
+CONSTANT: PFD_MAIN_PLANE 0
+CONSTANT: PFD_OVERLAY_PLANE 1
+CONSTANT: PFD_UNDERLAY_PLANE -1
+CONSTANT: PFD_DOUBLEBUFFER 1
+CONSTANT: PFD_STEREO 2
+CONSTANT: PFD_DRAW_TO_WINDOW 4
+CONSTANT: PFD_DRAW_TO_BITMAP 8
+CONSTANT: PFD_SUPPORT_GDI 16
+CONSTANT: PFD_SUPPORT_OPENGL 32
+CONSTANT: PFD_GENERIC_FORMAT 64
+CONSTANT: PFD_NEED_PALETTE 128
+CONSTANT: PFD_NEED_SYSTEM_PALETTE HEX: 00000100
+CONSTANT: PFD_SWAP_EXCHANGE HEX: 00000200
+CONSTANT: PFD_SWAP_COPY HEX: 00000400
+CONSTANT: PFD_SWAP_LAYER_BUFFERS HEX: 00000800
+CONSTANT: PFD_GENERIC_ACCELERATED HEX: 00001000
+CONSTANT: PFD_DEPTH_DONTCARE HEX: 20000000
+CONSTANT: PFD_DOUBLEBUFFER_DONTCARE HEX: 40000000
+CONSTANT: PFD_STEREO_DONTCARE HEX: 80000000
+CONSTANT: SP_ERROR -1
+CONSTANT: SP_OUTOFDISK -4
+CONSTANT: SP_OUTOFMEMORY -5
+CONSTANT: SP_USERABORT -3
+CONSTANT: SP_APPABORT -2
+CONSTANT: BLACKNESS HEX: 00000042
+CONSTANT: NOTSRCERASE HEX: 001100A6
+CONSTANT: NOTSRCCOPY HEX: 00330008
+CONSTANT: SRCERASE HEX: 00440328
+CONSTANT: DSTINVERT HEX: 00550009
+CONSTANT: PATINVERT HEX: 005A0049
+CONSTANT: SRCINVERT HEX: 00660046
+CONSTANT: SRCAND HEX: 008800C6
+CONSTANT: MERGEPAINT HEX: 00BB0226
+CONSTANT: MERGECOPY HEX: 00C000CA
+CONSTANT: SRCCOPY HEX: 00CC0020
+CONSTANT: SRCPAINT HEX: 00EE0086
+CONSTANT: PATCOPY HEX: 00F00021
+CONSTANT: PATPAINT HEX: 00FB0A09
+CONSTANT: WHITENESS HEX: 00FF0062
+CONSTANT: CAPTUREBLT HEX: 40000000
+CONSTANT: NOMIRRORBITMAP HEX: 80000000
+CONSTANT: R2_BLACK 1
+CONSTANT: R2_COPYPEN 13
+CONSTANT: R2_MASKNOTPEN 3
+CONSTANT: R2_MASKPEN 9
+CONSTANT: R2_MASKPENNOT 5
+CONSTANT: R2_MERGENOTPEN 12
+CONSTANT: R2_MERGEPEN 15
+CONSTANT: R2_MERGEPENNOT 14
+CONSTANT: R2_NOP 11
+CONSTANT: R2_NOT 6
+CONSTANT: R2_NOTCOPYPEN 4
+CONSTANT: R2_NOTMASKPEN 8
+CONSTANT: R2_NOTMERGEPEN 2
+CONSTANT: R2_NOTXORPEN 10
+CONSTANT: R2_WHITE 16
+CONSTANT: R2_XORPEN 7
+CONSTANT: CM_OUT_OF_GAMUT 255
+CONSTANT: CM_IN_GAMUT 0
+CONSTANT: RGN_AND 1
+CONSTANT: RGN_COPY 5
+CONSTANT: RGN_DIFF 4
+CONSTANT: RGN_OR 2
+CONSTANT: RGN_XOR 3
+CONSTANT: NULLREGION 1
+CONSTANT: SIMPLEREGION 2
+CONSTANT: COMPLEXREGION 3
+CONSTANT: ERROR 0
+CONSTANT: CBM_INIT 4
+CONSTANT: DIB_PAL_COLORS 1
+CONSTANT: DIB_RGB_COLORS 0
+CONSTANT: FW_DONTCARE 0
+CONSTANT: FW_THIN 100
+CONSTANT: FW_EXTRALIGHT 200
+ALIAS: FW_ULTRALIGHT FW_EXTRALIGHT
+CONSTANT: FW_LIGHT 300
+CONSTANT: FW_NORMAL 400
+CONSTANT: FW_REGULAR 400
+CONSTANT: FW_MEDIUM 500
+CONSTANT: FW_SEMIBOLD 600
+ALIAS: FW_DEMIBOLD FW_SEMIBOLD
+CONSTANT: FW_BOLD 700
+CONSTANT: FW_EXTRABOLD 800
+ALIAS: FW_ULTRABOLD FW_EXTRABOLD
+CONSTANT: FW_HEAVY 900
+ALIAS: FW_BLACK FW_HEAVY
+CONSTANT: ANSI_CHARSET 0
+CONSTANT: DEFAULT_CHARSET 1
+CONSTANT: SYMBOL_CHARSET 2
+CONSTANT: SHIFTJIS_CHARSET 128
+CONSTANT: HANGEUL_CHARSET 129
+CONSTANT: HANGUL_CHARSET 129
+CONSTANT: GB2312_CHARSET 134
+CONSTANT: CHINESEBIG5_CHARSET 136
+CONSTANT: GREEK_CHARSET 161
+CONSTANT: TURKISH_CHARSET 162
+CONSTANT: HEBREW_CHARSET 177
+CONSTANT: ARABIC_CHARSET 178
+CONSTANT: BALTIC_CHARSET 186
+CONSTANT: RUSSIAN_CHARSET 204
+CONSTANT: THAI_CHARSET 222
+CONSTANT: EASTEUROPE_CHARSET 238
+CONSTANT: OEM_CHARSET 255
+CONSTANT: JOHAB_CHARSET 130
+CONSTANT: VIETNAMESE_CHARSET 163
+CONSTANT: MAC_CHARSET 77
+CONSTANT: OUT_DEFAULT_PRECIS 0
+CONSTANT: OUT_STRING_PRECIS 1
+CONSTANT: OUT_CHARACTER_PRECIS 2
+CONSTANT: OUT_STROKE_PRECIS 3
+CONSTANT: OUT_TT_PRECIS 4
+CONSTANT: OUT_DEVICE_PRECIS 5
+CONSTANT: OUT_RASTER_PRECIS 6
+CONSTANT: OUT_TT_ONLY_PRECIS 7
+CONSTANT: OUT_OUTLINE_PRECIS 8
+CONSTANT: CLIP_DEFAULT_PRECIS 0
+CONSTANT: CLIP_CHARACTER_PRECIS 1
+CONSTANT: CLIP_STROKE_PRECIS 2
+CONSTANT: CLIP_MASK 15
+CONSTANT: CLIP_LH_ANGLES 16
+CONSTANT: CLIP_TT_ALWAYS 32
+CONSTANT: CLIP_EMBEDDED 128
+CONSTANT: DEFAULT_QUALITY 0
+CONSTANT: DRAFT_QUALITY 1
+CONSTANT: PROOF_QUALITY 2
+CONSTANT: NONANTIALIASED_QUALITY 3
+CONSTANT: ANTIALIASED_QUALITY 4
+CONSTANT: DEFAULT_PITCH 0
+CONSTANT: FIXED_PITCH 1
+CONSTANT: VARIABLE_PITCH 2
+CONSTANT: MONO_FONT 8
+CONSTANT: FF_DECORATIVE 80
+CONSTANT: FF_DONTCARE 0
+CONSTANT: FF_MODERN 48
+CONSTANT: FF_ROMAN 16
+CONSTANT: FF_SCRIPT 64
+CONSTANT: FF_SWISS 32
+CONSTANT: PANOSE_COUNT 10
+CONSTANT: PAN_FAMILYTYPE_INDEX 0
+CONSTANT: PAN_SERIFSTYLE_INDEX 1
+CONSTANT: PAN_WEIGHT_INDEX 2
+CONSTANT: PAN_PROPORTION_INDEX 3
+CONSTANT: PAN_CONTRAST_INDEX 4
+CONSTANT: PAN_STROKEVARIATION_INDEX 5
+CONSTANT: PAN_ARMSTYLE_INDEX 6
+CONSTANT: PAN_LETTERFORM_INDEX 7
+CONSTANT: PAN_MIDLINE_INDEX 8
+CONSTANT: PAN_XHEIGHT_INDEX 9
+CONSTANT: PAN_CULTURE_LATIN 0
+CONSTANT: PAN_ANY 0
+CONSTANT: PAN_NO_FIT 1
+CONSTANT: PAN_FAMILY_TEXT_DISPLAY 2
+CONSTANT: PAN_FAMILY_SCRIPT 3
+CONSTANT: PAN_FAMILY_DECORATIVE 4
+CONSTANT: PAN_FAMILY_PICTORIAL 5
+CONSTANT: PAN_SERIF_COVE 2
+CONSTANT: PAN_SERIF_OBTUSE_COVE 3
+CONSTANT: PAN_SERIF_SQUARE_COVE 4
+CONSTANT: PAN_SERIF_OBTUSE_SQUARE_COVE 5
+CONSTANT: PAN_SERIF_SQUARE 6
+CONSTANT: PAN_SERIF_THIN 7
+CONSTANT: PAN_SERIF_BONE 8
+CONSTANT: PAN_SERIF_EXAGGERATED 9
+CONSTANT: PAN_SERIF_TRIANGLE 10
+CONSTANT: PAN_SERIF_NORMAL_SANS 11
+CONSTANT: PAN_SERIF_OBTUSE_SANS 12
+CONSTANT: PAN_SERIF_PERP_SANS 13
+CONSTANT: PAN_SERIF_FLARED 14
+CONSTANT: PAN_SERIF_ROUNDED 15
+CONSTANT: PAN_WEIGHT_VERY_LIGHT 2
+CONSTANT: PAN_WEIGHT_LIGHT 3
+CONSTANT: PAN_WEIGHT_THIN 4
+CONSTANT: PAN_WEIGHT_BOOK 5
+CONSTANT: PAN_WEIGHT_MEDIUM 6
+CONSTANT: PAN_WEIGHT_DEMI 7
+CONSTANT: PAN_WEIGHT_BOLD 8
+CONSTANT: PAN_WEIGHT_HEAVY 9
+CONSTANT: PAN_WEIGHT_BLACK 10
+CONSTANT: PAN_WEIGHT_NORD 11
+CONSTANT: PAN_PROP_OLD_STYLE 2
+CONSTANT: PAN_PROP_MODERN 3
+CONSTANT: PAN_PROP_EVEN_WIDTH 4
+CONSTANT: PAN_PROP_EXPANDED 5
+CONSTANT: PAN_PROP_CONDENSED 6
+CONSTANT: PAN_PROP_VERY_EXPANDED 7
+CONSTANT: PAN_PROP_VERY_CONDENSED 8
+CONSTANT: PAN_PROP_MONOSPACED 9
+CONSTANT: PAN_CONTRAST_NONE 2
+CONSTANT: PAN_CONTRAST_VERY_LOW 3
+CONSTANT: PAN_CONTRAST_LOW 4
+CONSTANT: PAN_CONTRAST_MEDIUM_LOW 5
+CONSTANT: PAN_CONTRAST_MEDIUM 6
+CONSTANT: PAN_CONTRAST_MEDIUM_HIGH 7
+CONSTANT: PAN_CONTRAST_HIGH 8
+CONSTANT: PAN_CONTRAST_VERY_HIGH 9
+CONSTANT: PAN_STROKE_GRADUAL_DIAG 2
+CONSTANT: PAN_STROKE_GRADUAL_TRAN 3
+CONSTANT: PAN_STROKE_GRADUAL_VERT 4
+CONSTANT: PAN_STROKE_GRADUAL_HORZ 5
+CONSTANT: PAN_STROKE_RAPID_VERT 6
+CONSTANT: PAN_STROKE_RAPID_HORZ 7
+CONSTANT: PAN_STROKE_INSTANT_VERT 8
+CONSTANT: PAN_STRAIGHT_ARMS_HORZ 2
+CONSTANT: PAN_STRAIGHT_ARMS_WEDGE 3
+CONSTANT: PAN_STRAIGHT_ARMS_VERT 4
+CONSTANT: PAN_STRAIGHT_ARMS_SINGLE_SERIF 5
+CONSTANT: PAN_STRAIGHT_ARMS_DOUBLE_SERIF 6
+CONSTANT: PAN_BENT_ARMS_HORZ 7
+CONSTANT: PAN_BENT_ARMS_WEDGE 8
+CONSTANT: PAN_BENT_ARMS_VERT 9
+CONSTANT: PAN_BENT_ARMS_SINGLE_SERIF 10
+CONSTANT: PAN_BENT_ARMS_DOUBLE_SERIF 11
+CONSTANT: PAN_LETT_NORMAL_CONTACT 2
+CONSTANT: PAN_LETT_NORMAL_WEIGHTED 3
+CONSTANT: PAN_LETT_NORMAL_BOXED 4
+CONSTANT: PAN_LETT_NORMAL_FLATTENED 5
+CONSTANT: PAN_LETT_NORMAL_ROUNDED 6
+CONSTANT: PAN_LETT_NORMAL_OFF_CENTER 7
+CONSTANT: PAN_LETT_NORMAL_SQUARE 8
+CONSTANT: PAN_LETT_OBLIQUE_CONTACT 9
+CONSTANT: PAN_LETT_OBLIQUE_WEIGHTED 10
+CONSTANT: PAN_LETT_OBLIQUE_BOXED 11
+CONSTANT: PAN_LETT_OBLIQUE_FLATTENED 12
+CONSTANT: PAN_LETT_OBLIQUE_ROUNDED 13
+CONSTANT: PAN_LETT_OBLIQUE_OFF_CENTER 14
+CONSTANT: PAN_LETT_OBLIQUE_SQUARE 15
+CONSTANT: PAN_MIDLINE_STANDARD_TRIMMED 2
+CONSTANT: PAN_MIDLINE_STANDARD_POINTED 3
+CONSTANT: PAN_MIDLINE_STANDARD_SERIFED 4
+CONSTANT: PAN_MIDLINE_HIGH_TRIMMED 5
+CONSTANT: PAN_MIDLINE_HIGH_POINTED 6
+CONSTANT: PAN_MIDLINE_HIGH_SERIFED 7
+CONSTANT: PAN_MIDLINE_CONSTANT_TRIMMED 8
+CONSTANT: PAN_MIDLINE_CONSTANT_POINTED 9
+CONSTANT: PAN_MIDLINE_CONSTANT_SERIFED 10
+CONSTANT: PAN_MIDLINE_LOW_TRIMMED 11
+CONSTANT: PAN_MIDLINE_LOW_POINTED 12
+CONSTANT: PAN_MIDLINE_LOW_SERIFED 13
+CONSTANT: PAN_XHEIGHT_CONSTANT_SMALL 2
+CONSTANT: PAN_XHEIGHT_CONSTANT_STD 3
+CONSTANT: PAN_XHEIGHT_CONSTANT_LARGE 4
+CONSTANT: PAN_XHEIGHT_DUCKING_SMALL 5
+CONSTANT: PAN_XHEIGHT_DUCKING_STD 6
+CONSTANT: PAN_XHEIGHT_DUCKING_LARGE 7
+CONSTANT: FS_LATIN1 1
+CONSTANT: FS_LATIN2 2
+CONSTANT: FS_CYRILLIC 4
+CONSTANT: FS_GREEK 8
+CONSTANT: FS_TURKISH 16
+CONSTANT: FS_HEBREW 32
+CONSTANT: FS_ARABIC 64
+CONSTANT: FS_BALTIC 128
+CONSTANT: FS_THAI HEX: 10000
+CONSTANT: FS_JISJAPAN HEX: 20000
+CONSTANT: FS_CHINESESIMP HEX: 40000
+CONSTANT: FS_WANSUNG HEX: 80000
+CONSTANT: FS_CHINESETRAD HEX: 100000
+CONSTANT: FS_JOHAB HEX: 200000
+CONSTANT: FS_SYMBOL HEX: 80000000
+CONSTANT: HS_BDIAGONAL 3
+CONSTANT: HS_CROSS 4
+CONSTANT: HS_DIAGCROSS 5
+CONSTANT: HS_FDIAGONAL 2
+CONSTANT: HS_HORIZONTAL 0
+CONSTANT: HS_VERTICAL 1
+CONSTANT: PS_GEOMETRIC 65536
+CONSTANT: PS_COSMETIC 0
+CONSTANT: PS_ALTERNATE 8
+CONSTANT: PS_SOLID 0
+CONSTANT: PS_DASH 1
+CONSTANT: PS_DOT 2
+CONSTANT: PS_DASHDOT 3
+CONSTANT: PS_DASHDOTDOT 4
+CONSTANT: PS_NULL 5
+CONSTANT: PS_USERSTYLE 7
+CONSTANT: PS_INSIDEFRAME 6
+CONSTANT: PS_ENDCAP_ROUND 0
+CONSTANT: PS_ENDCAP_SQUARE 256
+CONSTANT: PS_ENDCAP_FLAT 512
+CONSTANT: PS_JOIN_BEVEL 4096
+CONSTANT: PS_JOIN_MITER 8192
+CONSTANT: PS_JOIN_ROUND 0
+CONSTANT: PS_STYLE_MASK 15
+CONSTANT: PS_ENDCAP_MASK 3840
+CONSTANT: PS_TYPE_MASK 983040
+CONSTANT: ALTERNATE 1
+CONSTANT: WINDING 2
+CONSTANT: DC_BINNAMES 12
+CONSTANT: DC_BINS 6
+CONSTANT: DC_COPIES 18
+CONSTANT: DC_DRIVER 11
+CONSTANT: DC_DATATYPE_PRODUCED 21
+CONSTANT: DC_DUPLEX 7
+CONSTANT: DC_EMF_COMPLIANT 20
+CONSTANT: DC_ENUMRESOLUTIONS 13
+CONSTANT: DC_EXTRA 9
+CONSTANT: DC_FIELDS 1
+CONSTANT: DC_FILEDEPENDENCIES 14
+CONSTANT: DC_MAXEXTENT 5
+CONSTANT: DC_MINEXTENT 4
+CONSTANT: DC_ORIENTATION 17
+CONSTANT: DC_PAPERNAMES 16
+CONSTANT: DC_PAPERS 2
+CONSTANT: DC_PAPERSIZE 3
+CONSTANT: DC_SIZE 8
+CONSTANT: DC_TRUETYPE 15
+CONSTANT: DCTT_BITMAP 1
+CONSTANT: DCTT_DOWNLOAD 2
+CONSTANT: DCTT_SUBDEV 4
+CONSTANT: DCTT_DOWNLOAD_OUTLINE 8
+CONSTANT: DC_VERSION 10
+CONSTANT: DC_BINADJUST 19
+CONSTANT: DC_MANUFACTURER 23
+CONSTANT: DC_MODEL 24
+CONSTANT: DC_PERSONALITY 25
+CONSTANT: DC_PRINTRATE 26
+CONSTANT: DC_PRINTRATEUNIT 27
+CONSTANT: DC_PRINTERMEM 28
+CONSTANT: DC_MEDIAREADY 29
+CONSTANT: DC_STAPLE 30
+CONSTANT: DC_PRINTRATEPPM 31
+CONSTANT: DC_COLORDEVICE 32
+CONSTANT: DC_NUP 33
+CONSTANT: DC_MEDIATYPENAMES 34
+CONSTANT: DC_MEDIATYPES 35
+CONSTANT: DCBA_FACEUPNONE 0
+CONSTANT: DCBA_FACEUPCENTER 1
+CONSTANT: DCBA_FACEUPLEFT 2
+CONSTANT: DCBA_FACEUPRIGHT 3
+CONSTANT: DCBA_FACEDOWNNONE 256
+CONSTANT: DCBA_FACEDOWNCENTER 257
+CONSTANT: DCBA_FACEDOWNLEFT 258
+CONSTANT: DCBA_FACEDOWNRIGHT 259
+CONSTANT: FLOODFILLBORDER 0
+CONSTANT: FLOODFILLSURFACE 1
+CONSTANT: ETO_CLIPPED HEX: 0004
+CONSTANT: ETO_GLYPH_INDEX HEX: 0010
+CONSTANT: ETO_OPAQUE HEX: 0002
+CONSTANT: ETO_NUMERICSLATIN HEX: 0800
+CONSTANT: ETO_NUMERICSLOCAL HEX: 0400
+CONSTANT: ETO_RTLREADING HEX: 0080
+CONSTANT: ETO_IGNORELANGUAGE HEX: 1000
+CONSTANT: ETO_PDY HEX: 2000
+CONSTANT: GDICOMMENT_WINDOWS_METAFILE -2147483647
+CONSTANT: GDICOMMENT_BEGINGROUP 2
+CONSTANT: GDICOMMENT_ENDGROUP 3
+CONSTANT: GDICOMMENT_MULTIFORMATS 1073741828
+CONSTANT: GDICOMMENT_IDENTIFIER 1128875079
+CONSTANT: AD_COUNTERCLOCKWISE 1
+CONSTANT: AD_CLOCKWISE 2
+CONSTANT: RDH_RECTANGLES 1
+CONSTANT: GCPCLASS_LATIN 1
+CONSTANT: GCPCLASS_HEBREW 2
+CONSTANT: GCPCLASS_ARABIC 2
+CONSTANT: GCPCLASS_NEUTRAL 3
+CONSTANT: GCPCLASS_LOCALNUMBER 4
+CONSTANT: GCPCLASS_LATINNUMBER 5
+CONSTANT: GCPCLASS_LATINNUMERICTERMINATOR 6
+CONSTANT: GCPCLASS_LATINNUMERICSEPARATOR 7
+CONSTANT: GCPCLASS_NUMERICSEPARATOR 8
+CONSTANT: GCPCLASS_PREBOUNDLTR 128
+CONSTANT: GCPCLASS_PREBOUNDRTL 64
+CONSTANT: GCPCLASS_POSTBOUNDLTR 32
+CONSTANT: GCPCLASS_POSTBOUNDRTL 16
+CONSTANT: GCPGLYPH_LINKBEFORE HEX: 8000
+CONSTANT: GCPGLYPH_LINKAFTER HEX: 4000
+CONSTANT: DCB_DISABLE 8
+CONSTANT: DCB_ENABLE 4
+CONSTANT: DCB_RESET 1
+CONSTANT: DCB_SET 3
+CONSTANT: DCB_ACCUMULATE 2
+CONSTANT: DCB_DIRTY 2
+CONSTANT: OBJ_BRUSH 2
+CONSTANT: OBJ_PEN 1
+CONSTANT: OBJ_PAL 5
+CONSTANT: OBJ_FONT 6
+CONSTANT: OBJ_BITMAP 7
+CONSTANT: OBJ_EXTPEN 11
+CONSTANT: OBJ_REGION 8
+CONSTANT: OBJ_DC 3
+CONSTANT: OBJ_MEMDC 10
+CONSTANT: OBJ_METAFILE 9
+CONSTANT: OBJ_METADC 4
+CONSTANT: OBJ_ENHMETAFILE 13
+CONSTANT: OBJ_ENHMETADC 12
+CONSTANT: DRIVERVERSION 0
+CONSTANT: TECHNOLOGY 2
+CONSTANT: DT_PLOTTER 0
+CONSTANT: DT_RASDISPLAY 1
+CONSTANT: DT_RASPRINTER 2
+CONSTANT: DT_RASCAMERA 3
+CONSTANT: DT_CHARSTREAM 4
+CONSTANT: DT_METAFILE 5
+CONSTANT: DT_DISPFILE 6
+CONSTANT: HORZSIZE 4
+CONSTANT: VERTSIZE 6
+CONSTANT: HORZRES 8
+CONSTANT: VERTRES 10
+CONSTANT: LOGPIXELSX 88
+CONSTANT: LOGPIXELSY 90
+CONSTANT: BITSPIXEL 12
+CONSTANT: PLANES 14
+CONSTANT: NUMBRUSHES 16
+CONSTANT: NUMPENS 18
+CONSTANT: NUMFONTS 22
+CONSTANT: NUMCOLORS 24
+CONSTANT: NUMMARKERS 20
+CONSTANT: ASPECTX 40
+CONSTANT: ASPECTY 42
+CONSTANT: ASPECTXY 44
+CONSTANT: PDEVICESIZE 26
+CONSTANT: CLIPCAPS 36
+CONSTANT: SIZEPALETTE 104
+CONSTANT: NUMRESERVED 106
+CONSTANT: COLORRES 108
+CONSTANT: PHYSICALWIDTH 110
+CONSTANT: PHYSICALHEIGHT 111
+CONSTANT: PHYSICALOFFSETX 112
+CONSTANT: PHYSICALOFFSETY 113
+CONSTANT: SCALINGFACTORX 114
+CONSTANT: SCALINGFACTORY 115
+CONSTANT: VREFRESH 116
+CONSTANT: DESKTOPHORZRES 118
+CONSTANT: DESKTOPVERTRES 117
+CONSTANT: BLTALIGNMENT 119
+CONSTANT: SHADEBLENDCAPS 120
+CONSTANT: SB_NONE HEX: 00
+CONSTANT: SB_CONST_ALPHA HEX: 01
+CONSTANT: SB_PIXEL_ALPHA HEX: 02
+CONSTANT: SB_PREMULT_ALPHA HEX: 04
+CONSTANT: SB_GRAD_RECT HEX: 10
+CONSTANT: SB_GRAD_TRI HEX: 20
+CONSTANT: COLORMGMTCAPS 121
+CONSTANT: CM_NONE HEX: 00
+CONSTANT: CM_DEVICE_ICM HEX: 01
+CONSTANT: CM_GAMMA_RAMP HEX: 02
+CONSTANT: CM_CMYK_COLOR HEX: 04
+CONSTANT: RASTERCAPS 38
+CONSTANT: RC_BITBLT 1
+CONSTANT: RC_BITMAP64 8
+CONSTANT: RC_DI_BITMAP 128
+CONSTANT: RC_DIBTODEV 512
+CONSTANT: RC_FLOODFILL 4096
+CONSTANT: RC_STRETCHBLT 2048
+CONSTANT: RC_STRETCHDIB 8192
+CONSTANT: CURVECAPS 28
+CONSTANT: CC_NONE 0
+CONSTANT: CC_CIRCLES 1
+CONSTANT: CC_PIE 2
+CONSTANT: CC_CHORD 4
+CONSTANT: CC_ELLIPSES 8
+CONSTANT: CC_WIDE 16
+CONSTANT: CC_STYLED 32
+CONSTANT: CC_WIDESTYLED 64
+CONSTANT: CC_INTERIORS 128
+CONSTANT: CC_ROUNDRECT 256
+CONSTANT: LINECAPS 30
+CONSTANT: LC_NONE 0
+CONSTANT: LC_POLYLINE 2
+CONSTANT: LC_MARKER 4
+CONSTANT: LC_POLYMARKER 8
+CONSTANT: LC_WIDE 16
+CONSTANT: LC_STYLED 32
+CONSTANT: LC_WIDESTYLED 64
+CONSTANT: LC_INTERIORS 128
+CONSTANT: POLYGONALCAPS 32
+CONSTANT: RC_BANDING 2
+CONSTANT: RC_BIGFONT 1024
+CONSTANT: RC_DEVBITS HEX: 8000
+CONSTANT: RC_GDI20_OUTPUT 16
+CONSTANT: RC_GDI20_STATE 32
+CONSTANT: RC_NONE 0
+CONSTANT: RC_OP_DX_OUTPUT HEX: 4000
+CONSTANT: RC_PALETTE 256
+CONSTANT: RC_SAVEBITMAP 64
+CONSTANT: RC_SCALING 4
+CONSTANT: PC_NONE 0
+CONSTANT: PC_POLYGON 1
+CONSTANT: PC_POLYPOLYGON 256
+CONSTANT: PC_PATHS 512
+CONSTANT: PC_RECTANGLE 2
+CONSTANT: PC_WINDPOLYGON 4
+CONSTANT: PC_SCANLINE 8
+CONSTANT: PC_TRAPEZOID 4
+CONSTANT: PC_WIDE 16
+CONSTANT: PC_STYLED 32
+CONSTANT: PC_WIDESTYLED 64
+CONSTANT: PC_INTERIORS 128
+CONSTANT: TEXTCAPS 34
+CONSTANT: TC_OP_CHARACTER 1
+CONSTANT: TC_OP_STROKE 2
+CONSTANT: TC_CP_STROKE 4
+CONSTANT: TC_CR_90 8
+CONSTANT: TC_CR_ANY 16
+CONSTANT: TC_SF_X_YINDEP 32
+CONSTANT: TC_SA_DOUBLE 64
+CONSTANT: TC_SA_INTEGER 128
+CONSTANT: TC_SA_CONTIN 256
+CONSTANT: TC_EA_DOUBLE 512
+CONSTANT: TC_IA_ABLE 1024
+CONSTANT: TC_UA_ABLE 2048
+CONSTANT: TC_SO_ABLE 4096
+CONSTANT: TC_RA_ABLE 8192
+CONSTANT: TC_VA_ABLE 16384
+CONSTANT: TC_RESERVED 32768
+CONSTANT: TC_SCROLLBLT 65536
+CONSTANT: GCP_DBCS 1
+CONSTANT: GCP_ERROR HEX: 8000
+CONSTANT: GCP_CLASSIN HEX: 80000
+CONSTANT: GCP_DIACRITIC 256
+CONSTANT: GCP_DISPLAYZWG HEX: 400000
+CONSTANT: GCP_GLYPHSHAPE 16
+CONSTANT: GCP_JUSTIFY HEX: 10000
+CONSTANT: GCP_JUSTIFYIN HEX: 200000
+CONSTANT: GCP_KASHIDA 1024
+CONSTANT: GCP_LIGATE 32
+CONSTANT: GCP_MAXEXTENT HEX: 100000
+CONSTANT: GCP_NEUTRALOVERRIDE HEX: 2000000
+CONSTANT: GCP_NUMERICOVERRIDE HEX: 1000000
+CONSTANT: GCP_NUMERICSLATIN HEX: 4000000
+CONSTANT: GCP_NUMERICSLOCAL HEX: 8000000
+CONSTANT: GCP_REORDER 2
+CONSTANT: GCP_SYMSWAPOFF HEX: 800000
+CONSTANT: GCP_USEKERNING 8
+CONSTANT: FLI_GLYPHS HEX: 40000
+CONSTANT: FLI_MASK HEX: 103b
+CONSTANT: GGO_METRICS 0
+CONSTANT: GGO_BITMAP 1
+CONSTANT: GGO_NATIVE 2
+CONSTANT: GGO_BEZIER 3
+CONSTANT: GGO_GRAY2_BITMAP 4
+CONSTANT: GGO_GRAY4_BITMAP 5
+CONSTANT: GGO_GRAY8_BITMAP 6
+CONSTANT: GGO_GLYPH_INDEX 128
+CONSTANT: GGO_UNHINTED 256
+CONSTANT: GM_COMPATIBLE 1
+CONSTANT: GM_ADVANCED 2
+CONSTANT: MM_ANISOTROPIC 8
+CONSTANT: MM_HIENGLISH 5
+CONSTANT: MM_HIMETRIC 3
+CONSTANT: MM_ISOTROPIC 7
+CONSTANT: MM_LOENGLISH 4
+CONSTANT: MM_LOMETRIC 2
+CONSTANT: MM_TEXT 1
+CONSTANT: MM_TWIPS 6
+ALIAS: MM_MAX_FIXEDSCALE MM_TWIPS
+CONSTANT: ABSOLUTE 1
+CONSTANT: RELATIVE 2
+CONSTANT: PC_EXPLICIT 2
+CONSTANT: PC_NOCOLLAPSE 4
+CONSTANT: PC_RESERVED 1
+CONSTANT: CLR_NONE HEX: ffffffff
+ALIAS: CLR_INVALID CLR_NONE
+CONSTANT: CLR_DEFAULT HEX: ff000000
+CONSTANT: PT_MOVETO 6
+CONSTANT: PT_LINETO 2
+CONSTANT: PT_BEZIERTO 4
+CONSTANT: PT_CLOSEFIGURE 1
+CONSTANT: TT_AVAILABLE 1
+CONSTANT: TT_ENABLED 2
+CONSTANT: BLACK_BRUSH 4
+CONSTANT: DKGRAY_BRUSH 3
+CONSTANT: GRAY_BRUSH 2
+CONSTANT: HOLLOW_BRUSH 5
+CONSTANT: LTGRAY_BRUSH 1
+CONSTANT: NULL_BRUSH 5
+CONSTANT: WHITE_BRUSH 0
+CONSTANT: BLACK_PEN 7
+CONSTANT: NULL_PEN 8
+CONSTANT: WHITE_PEN 6
+CONSTANT: ANSI_FIXED_FONT 11
+CONSTANT: ANSI_VAR_FONT 12
CONSTANT: DEVICE_DEFAULT_FONT 14
-CONSTANT: DEFAULT_PALETTE 15
-CONSTANT: SYSTEM_FIXED_FONT 16
-CONSTANT: DEFAULT_GUI_FONT 17
-CONSTANT: DC_BRUSH 18
-CONSTANT: DC_PEN 19
-
-CONSTANT: BI_RGB 0
-CONSTANT: BI_RLE8 1
-CONSTANT: BI_RLE4 2
-CONSTANT: BI_BITFIELDS 3
+CONSTANT: DEFAULT_GUI_FONT 17
+CONSTANT: OEM_FIXED_FONT 10
+CONSTANT: SYSTEM_FONT 13
+CONSTANT: SYSTEM_FIXED_FONT 16
+CONSTANT: DEFAULT_PALETTE 15
+CONSTANT: DC_BRUSH 18
+CONSTANT: DC_PEN 19
+CONSTANT: SYSPAL_ERROR 0
+CONSTANT: SYSPAL_STATIC 1
+CONSTANT: SYSPAL_NOSTATIC 2
+CONSTANT: SYSPAL_NOSTATIC256 3
+CONSTANT: TA_BASELINE 24
+CONSTANT: TA_BOTTOM 8
+CONSTANT: TA_TOP 0
+CONSTANT: TA_CENTER 6
+CONSTANT: TA_LEFT 0
+CONSTANT: TA_RIGHT 2
+CONSTANT: TA_RTLREADING 256
+CONSTANT: TA_NOUPDATECP 0
+CONSTANT: TA_UPDATECP 1
+: TA_MASK ( -- n ) { TA_BASELINE TA_CENTER TA_UPDATECP TA_RTLREADING } flags ; foldable
+CONSTANT: VTA_BASELINE 24
+CONSTANT: VTA_CENTER 6
+ALIAS: VTA_LEFT TA_BOTTOM
+ALIAS: VTA_RIGHT TA_TOP
+ALIAS: VTA_BOTTOM TA_RIGHT
+ALIAS: VTA_TOP TA_LEFT
+CONSTANT: MWT_IDENTITY 1
+CONSTANT: MWT_LEFTMULTIPLY 2
+CONSTANT: MWT_RIGHTMULTIPLY 3
+CONSTANT: OPAQUE 2
+CONSTANT: TRANSPARENT 1
+CONSTANT: BLACKONWHITE 1
+CONSTANT: WHITEONBLACK 2
+CONSTANT: COLORONCOLOR 3
+CONSTANT: HALFTONE 4
+CONSTANT: MAXSTRETCHBLTMODE 4
+CONSTANT: STRETCH_ANDSCANS 1
+CONSTANT: STRETCH_DELETESCANS 3
+CONSTANT: STRETCH_HALFTONE 4
+CONSTANT: STRETCH_ORSCANS 2
+CONSTANT: TCI_SRCCHARSET 1
+CONSTANT: TCI_SRCCODEPAGE 2
+CONSTANT: TCI_SRCFONTSIG 3
+CONSTANT: ICM_ON 2
+CONSTANT: ICM_OFF 1
+CONSTANT: ICM_QUERY 3
+CONSTANT: NEWFRAME 1
+CONSTANT: ABORTDOC 2
+CONSTANT: NEXTBAND 3
+CONSTANT: SETCOLORTABLE 4
+CONSTANT: GETCOLORTABLE 5
+CONSTANT: FLUSHOUTPUT 6
+CONSTANT: DRAFTMODE 7
+CONSTANT: QUERYESCSUPPORT 8
+CONSTANT: SETABORTPROC 9
+CONSTANT: STARTDOC 10
+CONSTANT: ENDDOC 11
+CONSTANT: GETPHYSPAGESIZE 12
+CONSTANT: GETPRINTINGOFFSET 13
+CONSTANT: GETSCALINGFACTOR 14
+CONSTANT: MFCOMMENT 15
+CONSTANT: GETPENWIDTH 16
+CONSTANT: SETCOPYCOUNT 17
+CONSTANT: SELECTPAPERSOURCE 18
+CONSTANT: DEVICEDATA 19
+CONSTANT: PASSTHROUGH 19
+CONSTANT: GETTECHNOLGY 20
+CONSTANT: GETTECHNOLOGY 20
+CONSTANT: SETLINECAP 21
+CONSTANT: SETLINEJOIN 22
+CONSTANT: SETMITERLIMIT 23
+CONSTANT: BANDINFO 24
+CONSTANT: DRAWPATTERNRECT 25
+CONSTANT: GETVECTORPENSIZE 26
+CONSTANT: GETVECTORBRUSHSIZE 27
+CONSTANT: ENABLEDUPLEX 28
+CONSTANT: GETSETPAPERBINS 29
+CONSTANT: GETSETPRINTORIENT 30
+CONSTANT: ENUMPAPERBINS 31
+CONSTANT: SETDIBSCALING 32
+CONSTANT: EPSPRINTING 33
+CONSTANT: ENUMPAPERMETRICS 34
+CONSTANT: GETSETPAPERMETRICS 35
+CONSTANT: POSTSCRIPT_DATA 37
+CONSTANT: POSTSCRIPT_IGNORE 38
+CONSTANT: MOUSETRAILS 39
+CONSTANT: GETDEVICEUNITS 42
+CONSTANT: GETEXTENDEDTEXTMETRICS 256
+CONSTANT: GETEXTENTTABLE 257
+CONSTANT: GETPAIRKERNTABLE 258
+CONSTANT: GETTRACKKERNTABLE 259
+CONSTANT: EXTTEXTOUT 512
+CONSTANT: GETFACENAME 513
+CONSTANT: DOWNLOADFACE 514
+CONSTANT: ENABLERELATIVEWIDTHS 768
+CONSTANT: ENABLEPAIRKERNING 769
+CONSTANT: SETKERNTRACK 770
+CONSTANT: SETALLJUSTVALUES 771
+CONSTANT: SETCHARSET 772
+CONSTANT: STRETCHBLT 2048
+CONSTANT: GETSETSCREENPARAMS 3072
+CONSTANT: QUERYDIBSUPPORT 3073
+CONSTANT: BEGIN_PATH 4096
+CONSTANT: CLIP_TO_PATH 4097
+CONSTANT: END_PATH 4098
+CONSTANT: EXT_DEVICE_CAPS 4099
+CONSTANT: RESTORE_CTM 4100
+CONSTANT: SAVE_CTM 4101
+CONSTANT: SET_ARC_DIRECTION 4102
+CONSTANT: SET_BACKGROUND_COLOR 4103
+CONSTANT: SET_POLY_MODE 4104
+CONSTANT: SET_SCREEN_ANGLE 4105
+CONSTANT: SET_SPREAD 4106
+CONSTANT: TRANSFORM_CTM 4107
+CONSTANT: SET_CLIP_BOX 4108
+CONSTANT: SET_BOUNDS 4109
+CONSTANT: SET_MIRROR_MODE 4110
+CONSTANT: OPENCHANNEL 4110
+CONSTANT: DOWNLOADHEADER 4111
+CONSTANT: CLOSECHANNEL 4112
+CONSTANT: POSTSCRIPT_PASSTHROUGH 4115
+CONSTANT: ENCAPSULATED_POSTSCRIPT 4116
+CONSTANT: QDI_SETDIBITS 1
+CONSTANT: QDI_GETDIBITS 2
+CONSTANT: QDI_DIBTOSCREEN 4
+CONSTANT: QDI_STRETCHDIB 8
+CONSTANT: SP_NOTREPORTED HEX: 4000
+CONSTANT: PR_JOBSTATUS 0
+CONSTANT: ASPECT_FILTERING 1
+CONSTANT: BS_SOLID 0
+CONSTANT: BS_NULL 1
+CONSTANT: BS_HOLLOW 1
+CONSTANT: BS_HATCHED 2
+CONSTANT: BS_PATTERN 3
+CONSTANT: BS_INDEXED 4
+CONSTANT: BS_DIBPATTERN 5
+CONSTANT: BS_DIBPATTERNPT 6
+CONSTANT: BS_PATTERN8X8 7
+CONSTANT: BS_DIBPATTERN8X8 8
+CONSTANT: LCS_CALIBRATED_RGB 0
+CONSTANT: LCS_DEVICE_RGB 1
+CONSTANT: LCS_DEVICE_CMYK 2
+CONSTANT: LCS_GM_BUSINESS 1
+CONSTANT: LCS_GM_GRAPHICS 2
+CONSTANT: LCS_GM_IMAGES 4
+CONSTANT: RASTER_FONTTYPE 1
+CONSTANT: DEVICE_FONTTYPE 2
+CONSTANT: TRUETYPE_FONTTYPE 4
+CONSTANT: DMORIENT_PORTRAIT 1
+CONSTANT: DMORIENT_LANDSCAPE 2
+CONSTANT: DMPAPER_FIRST 1
+CONSTANT: DMPAPER_LETTER 1
+CONSTANT: DMPAPER_LETTERSMALL 2
+CONSTANT: DMPAPER_TABLOID 3
+CONSTANT: DMPAPER_LEDGER 4
+CONSTANT: DMPAPER_LEGAL 5
+CONSTANT: DMPAPER_STATEMENT 6
+CONSTANT: DMPAPER_EXECUTIVE 7
+CONSTANT: DMPAPER_A3 8
+CONSTANT: DMPAPER_A4 9
+CONSTANT: DMPAPER_A4SMALL 10
+CONSTANT: DMPAPER_A5 11
+CONSTANT: DMPAPER_B4 12
+CONSTANT: DMPAPER_B5 13
+CONSTANT: DMPAPER_FOLIO 14
+CONSTANT: DMPAPER_QUARTO 15
+CONSTANT: DMPAPER_10X14 16
+CONSTANT: DMPAPER_11X17 17
+CONSTANT: DMPAPER_NOTE 18
+CONSTANT: DMPAPER_ENV_9 19
+CONSTANT: DMPAPER_ENV_10 20
+CONSTANT: DMPAPER_ENV_11 21
+CONSTANT: DMPAPER_ENV_12 22
+CONSTANT: DMPAPER_ENV_14 23
+CONSTANT: DMPAPER_CSHEET 24
+CONSTANT: DMPAPER_DSHEET 25
+CONSTANT: DMPAPER_ESHEET 26
+CONSTANT: DMPAPER_ENV_DL 27
+CONSTANT: DMPAPER_ENV_C5 28
+CONSTANT: DMPAPER_ENV_C3 29
+CONSTANT: DMPAPER_ENV_C4 30
+CONSTANT: DMPAPER_ENV_C6 31
+CONSTANT: DMPAPER_ENV_C65 32
+CONSTANT: DMPAPER_ENV_B4 33
+CONSTANT: DMPAPER_ENV_B5 34
+CONSTANT: DMPAPER_ENV_B6 35
+CONSTANT: DMPAPER_ENV_ITALY 36
+CONSTANT: DMPAPER_ENV_MONARCH 37
+CONSTANT: DMPAPER_ENV_PERSONAL 38
+CONSTANT: DMPAPER_FANFOLD_US 39
+CONSTANT: DMPAPER_FANFOLD_STD_GERMAN 40
+CONSTANT: DMPAPER_FANFOLD_LGL_GERMAN 41
+CONSTANT: DMPAPER_ISO_B4 42
+CONSTANT: DMPAPER_JAPANESE_POSTCARD 43
+CONSTANT: DMPAPER_9X11 44
+CONSTANT: DMPAPER_10X11 45
+CONSTANT: DMPAPER_15X11 46
+CONSTANT: DMPAPER_ENV_INVITE 47
+CONSTANT: DMPAPER_RESERVED_48 48
+CONSTANT: DMPAPER_RESERVED_49 49
+CONSTANT: DMPAPER_LETTER_EXTRA 50
+CONSTANT: DMPAPER_LEGAL_EXTRA 51
+CONSTANT: DMPAPER_TABLOID_EXTRA 52
+CONSTANT: DMPAPER_A4_EXTRA 53
+CONSTANT: DMPAPER_LETTER_TRANSVERSE 54
+CONSTANT: DMPAPER_A4_TRANSVERSE 55
+CONSTANT: DMPAPER_LETTER_EXTRA_TRANSVERSE 56
+CONSTANT: DMPAPER_A_PLUS 57
+CONSTANT: DMPAPER_B_PLUS 58
+CONSTANT: DMPAPER_LETTER_PLUS 59
+CONSTANT: DMPAPER_A4_PLUS 60
+CONSTANT: DMPAPER_A5_TRANSVERSE 61
+CONSTANT: DMPAPER_B5_TRANSVERSE 62
+CONSTANT: DMPAPER_A3_EXTRA 63
+CONSTANT: DMPAPER_A5_EXTRA 64
+CONSTANT: DMPAPER_B5_EXTRA 65
+CONSTANT: DMPAPER_A2 66
+CONSTANT: DMPAPER_A3_TRANSVERSE 67
+CONSTANT: DMPAPER_A3_EXTRA_TRANSVERSE 68
+CONSTANT: DMPAPER_DBL_JAPANESE_POSTCARD 69
+CONSTANT: DMPAPER_A6 70
+CONSTANT: DMPAPER_JENV_KAKU2 71
+CONSTANT: DMPAPER_JENV_KAKU3 72
+CONSTANT: DMPAPER_JENV_CHOU3 73
+CONSTANT: DMPAPER_JENV_CHOU4 74
+CONSTANT: DMPAPER_LETTER_ROTATED 75
+CONSTANT: DMPAPER_A3_ROTATED 76
+CONSTANT: DMPAPER_A4_ROTATED 77
+CONSTANT: DMPAPER_A5_ROTATED 78
+CONSTANT: DMPAPER_B4_JIS_ROTATED 79
+CONSTANT: DMPAPER_B5_JIS_ROTATED 80
+CONSTANT: DMPAPER_JAPANESE_POSTCARD_ROTATED 81
+CONSTANT: DMPAPER_DBL_JAPANESE_POSTCARD_ROTATED 82
+CONSTANT: DMPAPER_A6_ROTATED 83
+CONSTANT: DMPAPER_JENV_KAKU2_ROTATED 84
+CONSTANT: DMPAPER_JENV_KAKU3_ROTATED 85
+CONSTANT: DMPAPER_JENV_CHOU3_ROTATED 86
+CONSTANT: DMPAPER_JENV_CHOU4_ROTATED 87
+CONSTANT: DMPAPER_B6_JIS 88
+CONSTANT: DMPAPER_B6_JIS_ROTATED 89
+CONSTANT: DMPAPER_12X11 90
+CONSTANT: DMPAPER_JENV_YOU4 91
+CONSTANT: DMPAPER_JENV_YOU4_ROTATED 92
+CONSTANT: DMPAPER_P16K 93
+CONSTANT: DMPAPER_P32K 94
+CONSTANT: DMPAPER_P32KBIG 95
+CONSTANT: DMPAPER_PENV_1 96
+CONSTANT: DMPAPER_PENV_2 97
+CONSTANT: DMPAPER_PENV_3 98
+CONSTANT: DMPAPER_PENV_4 99
+CONSTANT: DMPAPER_PENV_5 100
+CONSTANT: DMPAPER_PENV_6 101
+CONSTANT: DMPAPER_PENV_7 102
+CONSTANT: DMPAPER_PENV_8 103
+CONSTANT: DMPAPER_PENV_9 104
+CONSTANT: DMPAPER_PENV_10 105
+CONSTANT: DMPAPER_P16K_ROTATED 106
+CONSTANT: DMPAPER_P32K_ROTATED 107
+CONSTANT: DMPAPER_P32KBIG_ROTATED 108
+CONSTANT: DMPAPER_PENV_1_ROTATED 109
+CONSTANT: DMPAPER_PENV_2_ROTATED 110
+CONSTANT: DMPAPER_PENV_3_ROTATED 111
+CONSTANT: DMPAPER_PENV_4_ROTATED 112
+CONSTANT: DMPAPER_PENV_5_ROTATED 113
+CONSTANT: DMPAPER_PENV_6_ROTATED 114
+CONSTANT: DMPAPER_PENV_7_ROTATED 115
+CONSTANT: DMPAPER_PENV_8_ROTATED 116
+CONSTANT: DMPAPER_PENV_9_ROTATED 117
+CONSTANT: DMPAPER_PENV_10_ROTATED 118
+CONSTANT: DMPAPER_LAST 118
+CONSTANT: DMPAPER_USER 256
+CONSTANT: DMBIN_FIRST 1
+CONSTANT: DMBIN_UPPER 1
+CONSTANT: DMBIN_ONLYONE 1
+CONSTANT: DMBIN_LOWER 2
+CONSTANT: DMBIN_MIDDLE 3
+CONSTANT: DMBIN_MANUAL 4
+CONSTANT: DMBIN_ENVELOPE 5
+CONSTANT: DMBIN_ENVMANUAL 6
+CONSTANT: DMBIN_AUTO 7
+CONSTANT: DMBIN_TRACTOR 8
+CONSTANT: DMBIN_SMALLFMT 9
+CONSTANT: DMBIN_LARGEFMT 10
+CONSTANT: DMBIN_LARGECAPACITY 11
+CONSTANT: DMBIN_CASSETTE 14
+CONSTANT: DMBIN_FORMSOURCE 15
+CONSTANT: DMBIN_LAST 15
+CONSTANT: DMBIN_USER 256
+CONSTANT: DMRES_DRAFT -1
+CONSTANT: DMRES_LOW -2
+CONSTANT: DMRES_MEDIUM -3
+CONSTANT: DMRES_HIGH -4
+CONSTANT: DMCOLOR_MONOCHROME 1
+CONSTANT: DMCOLOR_COLOR 2
+CONSTANT: DMDUP_SIMPLEX 1
+CONSTANT: DMDUP_VERTICAL 2
+CONSTANT: DMDUP_HORIZONTAL 3
+CONSTANT: DMTT_BITMAP 1
+CONSTANT: DMTT_DOWNLOAD 2
+CONSTANT: DMTT_SUBDEV 3
+CONSTANT: DMTT_DOWNLOAD_OUTLINE 4
+CONSTANT: DMCOLLATE_FALSE 0
+CONSTANT: DMCOLLATE_TRUE 1
+CONSTANT: DM_SPECVERSION 800
+CONSTANT: DM_GRAYSCALE 1
+CONSTANT: DM_INTERLACED 2
+CONSTANT: DM_UPDATE 1
+CONSTANT: DM_COPY 2
+CONSTANT: DM_PROMPT 4
+CONSTANT: DM_MODIFY 8
+ALIAS: DM_IN_BUFFER DM_MODIFY
+ALIAS: DM_IN_PROMPT DM_PROMPT
+ALIAS: DM_OUT_BUFFER DM_COPY
+ALIAS: DM_OUT_DEFAULT DM_UPDATE
+CONSTANT: DM_ORIENTATION HEX: 00000001
+CONSTANT: DM_PAPERSIZE HEX: 00000002
+CONSTANT: DM_PAPERLENGTH HEX: 00000004
+CONSTANT: DM_PAPERWIDTH HEX: 00000008
+CONSTANT: DM_SCALE HEX: 00000010
+CONSTANT: DM_POSITION HEX: 00000020
+CONSTANT: DM_COPIES HEX: 00000100
+CONSTANT: DM_DEFAULTSOURCE HEX: 00000200
+CONSTANT: DM_PRINTQUALITY HEX: 00000400
+CONSTANT: DM_COLOR HEX: 00000800
+CONSTANT: DM_DUPLEX HEX: 00001000
+CONSTANT: DM_YRESOLUTION HEX: 00002000
+CONSTANT: DM_TTOPTION HEX: 00004000
+CONSTANT: DM_COLLATE HEX: 00008000
+CONSTANT: DM_FORMNAME HEX: 00010000
+CONSTANT: DM_LOGPIXELS HEX: 00020000
+CONSTANT: DM_BITSPERPEL HEX: 00040000
+CONSTANT: DM_PELSWIDTH HEX: 00080000
+CONSTANT: DM_PELSHEIGHT HEX: 00100000
+CONSTANT: DM_DISPLAYFLAGS HEX: 00200000
+CONSTANT: DM_DISPLAYFREQUENCY HEX: 00400000
+CONSTANT: DM_ICMMETHOD HEX: 00800000
+CONSTANT: DM_ICMINTENT HEX: 01000000
+CONSTANT: DM_MEDIATYPE HEX: 02000000
+CONSTANT: DM_DITHERTYPE HEX: 04000000
+CONSTANT: DM_PANNINGWIDTH HEX: 08000000
+CONSTANT: DM_PANNINGHEIGHT HEX: 10000000
+CONSTANT: DM_DISPLAYFIXEDOUTPUT HEX: 20000000
+CONSTANT: DM_DISPLAYORIENTATION HEX: 00000080
+CONSTANT: DMDO_DEFAULT HEX: 00000000
+CONSTANT: DMDO_90 HEX: 00000001
+CONSTANT: DMDO_180 HEX: 00000002
+CONSTANT: DMDO_270 HEX: 00000003
+CONSTANT: DMDFO_DEFAULT HEX: 00000000
+CONSTANT: DMDFO_STRETCH HEX: 00000001
+CONSTANT: DMDFO_CENTER HEX: 00000002
+CONSTANT: DMICMMETHOD_NONE 1
+CONSTANT: DMICMMETHOD_SYSTEM 2
+CONSTANT: DMICMMETHOD_DRIVER 3
+CONSTANT: DMICMMETHOD_DEVICE 4
+CONSTANT: DMICMMETHOD_USER 256
+CONSTANT: DMICM_SATURATE 1
+CONSTANT: DMICM_CONTRAST 2
+CONSTANT: DMICM_COLORMETRIC 3
+CONSTANT: DMICM_USER 256
+CONSTANT: DMMEDIA_STANDARD 1
+CONSTANT: DMMEDIA_TRANSPARENCY 2
+CONSTANT: DMMEDIA_GLOSSY 3
+CONSTANT: DMMEDIA_USER 256
+CONSTANT: DMDITHER_NONE 1
+CONSTANT: DMDITHER_COARSE 2
+CONSTANT: DMDITHER_FINE 3
+CONSTANT: DMDITHER_LINEART 4
+CONSTANT: DMDITHER_ERRORDIFFUSION 5
+CONSTANT: DMDITHER_RESERVED6 6
+CONSTANT: DMDITHER_RESERVED7 7
+CONSTANT: DMDITHER_RESERVED8 8
+CONSTANT: DMDITHER_RESERVED9 9
+CONSTANT: DMDITHER_GRAYSCALE 10
+CONSTANT: DMDITHER_USER 256
+CONSTANT: GDI_ERROR HEX: FFFFFFFF
+: HGDI_ERROR ( -- alien ) GDI_ERROR <alien> ; inline
+CONSTANT: TMPF_FIXED_PITCH 1
+CONSTANT: TMPF_VECTOR 2
+CONSTANT: TMPF_TRUETYPE 4
+CONSTANT: TMPF_DEVICE 8
+CONSTANT: NTM_ITALIC 1
+CONSTANT: NTM_BOLD 32
+CONSTANT: NTM_REGULAR 64
+CONSTANT: TT_POLYGON_TYPE 24
+CONSTANT: TT_PRIM_LINE 1
+CONSTANT: TT_PRIM_QSPLINE 2
+CONSTANT: TT_PRIM_CSPLINE 3
+CONSTANT: FONTMAPPER_MAX 10
+CONSTANT: ENHMETA_STOCK_OBJECT HEX: 80000000
+CONSTANT: WGL_FONT_LINES 0
+CONSTANT: WGL_FONT_POLYGONS 1
+CONSTANT: LPD_DOUBLEBUFFER 1
+CONSTANT: LPD_STEREO 2
+CONSTANT: LPD_SUPPORT_GDI 16
+CONSTANT: LPD_SUPPORT_OPENGL 32
+CONSTANT: LPD_SHARE_DEPTH 64
+CONSTANT: LPD_SHARE_STENCIL 128
+CONSTANT: LPD_SHARE_ACCUM 256
+CONSTANT: LPD_SWAP_EXCHANGE 512
+CONSTANT: LPD_SWAP_COPY 1024
+CONSTANT: LPD_TRANSPARENT 4096
+CONSTANT: LPD_TYPE_RGBA 0
+CONSTANT: LPD_TYPE_COLORINDEX 1
+CONSTANT: WGL_SWAP_MAIN_PLANE 1
+CONSTANT: WGL_SWAP_OVERLAY1 2
+CONSTANT: WGL_SWAP_OVERLAY2 4
+CONSTANT: WGL_SWAP_OVERLAY3 8
+CONSTANT: WGL_SWAP_OVERLAY4 16
+CONSTANT: WGL_SWAP_OVERLAY5 32
+CONSTANT: WGL_SWAP_OVERLAY6 64
+CONSTANT: WGL_SWAP_OVERLAY7 128
+CONSTANT: WGL_SWAP_OVERLAY8 256
+CONSTANT: WGL_SWAP_OVERLAY9 512
+CONSTANT: WGL_SWAP_OVERLAY10 1024
+CONSTANT: WGL_SWAP_OVERLAY11 2048
+CONSTANT: WGL_SWAP_OVERLAY12 4096
+CONSTANT: WGL_SWAP_OVERLAY13 8192
+CONSTANT: WGL_SWAP_OVERLAY14 16384
+CONSTANT: WGL_SWAP_OVERLAY15 32768
+CONSTANT: WGL_SWAP_UNDERLAY1 65536
+CONSTANT: WGL_SWAP_UNDERLAY2 HEX: 20000
+CONSTANT: WGL_SWAP_UNDERLAY3 HEX: 40000
+CONSTANT: WGL_SWAP_UNDERLAY4 HEX: 80000
+CONSTANT: WGL_SWAP_UNDERLAY5 HEX: 100000
+CONSTANT: WGL_SWAP_UNDERLAY6 HEX: 200000
+CONSTANT: WGL_SWAP_UNDERLAY7 HEX: 400000
+CONSTANT: WGL_SWAP_UNDERLAY8 HEX: 800000
+CONSTANT: WGL_SWAP_UNDERLAY9 HEX: 1000000
+CONSTANT: WGL_SWAP_UNDERLAY10 HEX: 2000000
+CONSTANT: WGL_SWAP_UNDERLAY11 HEX: 4000000
+CONSTANT: WGL_SWAP_UNDERLAY12 HEX: 8000000
+CONSTANT: WGL_SWAP_UNDERLAY13 HEX: 10000000
+CONSTANT: WGL_SWAP_UNDERLAY14 HEX: 20000000
+CONSTANT: WGL_SWAP_UNDERLAY15 HEX: 40000000
+CONSTANT: AC_SRC_OVER HEX: 00
+CONSTANT: AC_SRC_ALPHA HEX: 01
+CONSTANT: AC_SRC_NO_PREMULT_ALPHA HEX: 01
+CONSTANT: AC_SRC_NO_ALPHA HEX: 02
+CONSTANT: AC_DST_NO_PREMULT_ALPHA HEX: 10
+CONSTANT: AC_DST_NO_ALPHA HEX: 20
+CONSTANT: LAYOUT_RTL 1
+CONSTANT: LAYOUT_BITMAPORIENTATIONPRESERVED 8
+CONSTANT: CS_ENABLE HEX: 00000001
+CONSTANT: CS_DISABLE HEX: 00000002
+CONSTANT: CS_DELETE_TRANSFORM HEX: 00000003
+CONSTANT: GRADIENT_FILL_RECT_H HEX: 00
+CONSTANT: GRADIENT_FILL_RECT_V HEX: 01
+CONSTANT: GRADIENT_FILL_TRIANGLE HEX: 02
+CONSTANT: GRADIENT_FILL_OP_FLAG HEX: ff
+CONSTANT: COLORMATCHTOTARGET_EMBEDED HEX: 00000001
+CONSTANT: CREATECOLORSPACE_EMBEDED HEX: 00000001
+CONSTANT: SETICMPROFILE_EMBEDED HEX: 00000001
-CONSTANT: DIB_RGB_COLORS 0
-CONSTANT: DIB_PAL_COLORS 1
+CONSTANT: DISPLAY_DEVICE_ATTACHED_TO_DESKTOP HEX: 00000001
+CONSTANT: DISPLAY_DEVICE_MULTI_DRIVER HEX: 00000002
+CONSTANT: DISPLAY_DEVICE_PRIMARY_DEVICE HEX: 00000004
+CONSTANT: DISPLAY_DEVICE_MIRRORING_DRIVER HEX: 00000008
+CONSTANT: DISPLAY_DEVICE_VGA_COMPATIBLE HEX: 00000010
+CONSTANT: DISPLAY_DEVICE_REMOVABLE HEX: 00000020
+CONSTANT: DISPLAY_DEVICE_MODESPRUNED HEX: 08000000
+
+CONSTANT: NTM_NONNEGATIVE_AC HEX: 00010000
+CONSTANT: NTM_PS_OPENTYPE HEX: 00020000
+CONSTANT: NTM_TT_OPENTYPE HEX: 00040000
+CONSTANT: NTM_MULTIPLEMASTER HEX: 00080000
+CONSTANT: NTM_TYPE1 HEX: 00100000
+CONSTANT: NTM_DSIG HEX: 00200000
+
+CONSTANT: GGI_MARK_NONEXISTING_GLYPHS 1
LIBRARY: gdi32
+! FUNCTION: AbortDoc
! FUNCTION: AbortPath
! FUNCTION: AddFontMemResourceEx
! FUNCTION: AddFontResourceA
! FUNCTION: CreateFontIndirectExA
! FUNCTION: CreateFontIndirectExW
! FUNCTION: CreateFontIndirectW
-! FUNCTION: CreateFontW
+FUNCTION: HFONT CreateFontW ( int nHeight, int nWidth, int nEscapement, int nOrientation, int fnWeight, DWORD fdwItalic, DWORD fdwUnderline, DWORD fdwStrikeOut, DWORD fdwCharSet, DWORD fdwOutputPrecision, DWORD fdwClipPrecision, DWORD fdwQuality, DWORD fdwPitchAndFamily, LPCTSTR lpszFace ) ;
+ALIAS: CreateFont CreateFontW
! FUNCTION: CreateHalftonePalette
! FUNCTION: CreateHatchBrush
! FUNCTION: CreateICA
! FUNCTION: CreateRoundRectRgn
! FUNCTION: CreateScalableFontResourceA
! FUNCTION: CreateScalableFontResourceW
-! FUNCTION: CreateSolidBrush
+FUNCTION: HBRUSH CreateSolidBrush ( COLORREF colorref ) ;
! FUNCTION: DdEntry0
! FUNCTION: DdEntry1
! FUNCTION: DdEntry10
! FUNCTION: DdEntry9
! FUNCTION: DeleteColorSpace
FUNCTION: BOOL DeleteDC ( HDC hdc ) ;
+DESTRUCTOR: DeleteDC
! FUNCTION: DeleteEnhMetaFile
! FUNCTION: DeleteMetaFile
FUNCTION: BOOL DeleteObject ( HGDIOBJ hObject ) ;
+DESTRUCTOR: DeleteObject
! FUNCTION: DescribePixelFormat
! FUNCTION: DeviceCapabilitiesExA
! FUNCTION: DeviceCapabilitiesExW
! FUNCTION: ExtFloodFill
! FUNCTION: ExtSelectClipRgn
! FUNCTION: ExtTextOutA
-! FUNCTION: ExtTextOutW
+FUNCTION: BOOL ExtTextOutW ( HDC hdc, int X, int Y, UINT fuOptions, RECT* lprc, LPCTSTR lpString, UINT cbCount, INT* lpDx ) ;
+ALIAS: ExtTextOut ExtTextOutW
! FUNCTION: FillPath
+FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ;
! FUNCTION: FillRgn
! FUNCTION: FixBrushOrgEx
! FUNCTION: FlattenPath
! FUNCTION: GetTextFaceAliasW
! FUNCTION: GetTextFaceW
! FUNCTION: GetTextMetricsA
-! FUNCTION: GetTextMetricsW
+FUNCTION: BOOL GetTextMetricsW ( HDC hdc, LPTEXTMETRIC lptm ) ;
+ALIAS: GetTextMetrics GetTextMetricsW
! FUNCTION: GetTransform
! FUNCTION: GetViewportExtEx
! FUNCTION: GetViewportOrgEx
! FUNCTION: PtVisible
! FUNCTION: QueryFontAssocStatus
! FUNCTION: RealizePalette
-! FUNCTION: Rectangle
+FUNCTION: BOOL Rectangle ( HDC hdc, int x, int y, int w, int h ) ;
! FUNCTION: RectInRegion
! FUNCTION: RectVisible
! FUNCTION: RemoveFontMemResourceEx
! FUNCTION: SetBitmapAttributes
! FUNCTION: SetBitmapBits
! FUNCTION: SetBitmapDimensionEx
-! FUNCTION: SetBkColor
+FUNCTION: COLORREF SetBkColor ( HDC hdc, COLORREF color ) ;
! FUNCTION: SetBkMode
! FUNCTION: SetBoundsRect
! FUNCTION: SetBrushAttributes
! FUNCTION: SetBrushOrgEx
! FUNCTION: SetColorAdjustment
! FUNCTION: SetColorSpace
-! FUNCTION: SetDCBrushColor
-! FUNCTION: SetDCPenColor
+FUNCTION: COLORREF SetDCBrushColor ( HDC hdc, COLORREF color ) ;
+FUNCTION: COLORREF SetDCPenColor ( HDC hdc, COLORREF color ) ;
! FUNCTION: SetDeviceGammaRamp
! FUNCTION: SetDIBColorTable
! FUNCTION: SetDIBits
! FUNCTION: SetSystemPaletteUse
! FUNCTION: SetTextAlign
! FUNCTION: SetTextCharacterExtra
-! FUNCTION: SetTextColor
+FUNCTION: COLORREF SetTextColor ( HDC hdc, COLORREF crColor ) ;
+! FUNCTION: SetTextColor ( HDC hDC,
! FUNCTION: SetTextJustification
! FUNCTION: SetViewportExtEx
! FUNCTION: SetViewportOrgEx
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: windows.offscreen.tests\r
+USING: windows.offscreen effects tools.test kernel images ;\r
+\r
+{ 1 1 } [ [ [ ] make-bitmap-image ] with-memory-dc ] must-infer-as\r
+[ t ] [ [ { 10 10 } swap [ ] make-bitmap-image ] with-memory-dc image? ] unit-test\r
--- /dev/null
+! Copyright (C) 2009 Joe Groff, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types kernel combinators sequences
+math windows.gdi32 windows.types images destructors
+accessors fry locals ;
+IN: windows.offscreen
+
+: (bitmap-info) ( dim -- BITMAPINFO )
+ "BITMAPINFO" <c-object> [
+ BITMAPINFO-bmiHeader {
+ [ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
+ [ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
+ [ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
+ [ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
+ [ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
+ [ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
+ [ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
+ [ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
+ [ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
+ [ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
+ [ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
+ } 2cleave
+ ] keep ;
+
+: make-bitmap ( dim dc -- hBitmap bits )
+ [ nip ]
+ [
+ swap (bitmap-info) DIB_RGB_COLORS f <void*>
+ [ f 0 CreateDIBSection ] keep *void*
+ ] 2bi
+ [ [ SelectObject drop ] keep ] dip ;
+
+: make-offscreen-dc-and-bitmap ( dim -- dc hBitmap bits )
+ [ f CreateCompatibleDC ] dip over make-bitmap ;
+
+: bitmap>byte-array ( bits dim -- byte-array )
+ product 4 * memory>byte-array ;
+
+: bitmap>image ( bits dim -- image )
+ [ bitmap>byte-array ] keep
+ <image>
+ swap >>dim
+ swap >>bitmap
+ BGRX >>component-order
+ t >>upside-down? ;
+
+: with-memory-dc ( quot: ( hDC -- ) -- )
+ [ [ f CreateCompatibleDC &DeleteDC ] dip call ] with-destructors ; inline
+
+:: make-bitmap-image ( dim dc quot -- image )
+ dim dc make-bitmap [ &DeleteObject drop ] dip
+ quot dip
+ dim bitmap>image ; inline
\ No newline at end of file
--- /dev/null
+Utility words for memory DCs and bitmaps\r
--- /dev/null
+unportable\r
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax namespaces kernel words ;
+USING: alien alien.c-types alien.syntax namespaces kernel words
+sequences math math.bitwise math.vectors colors ;
IN: windows.types
TYPEDEF: char CHAR
{ "LONG" "right" }
{ "LONG" "bottom" } ;
-! C-STRUCT: PAINTSTRUCT
- ! { "HDC" " hdc" }
- ! { "BOOL" "fErase" }
- ! { "RECT" "rcPaint" }
- ! { "BOOL" "fRestore" }
- ! { "BOOL" "fIncUpdate" }
- ! { "BYTE[32]" "rgbReserved" }
-! ;
+C-STRUCT: PAINTSTRUCT
+ { "HDC" " hdc" }
+ { "BOOL" "fErase" }
+ { "RECT" "rcPaint" }
+ { "BOOL" "fRestore" }
+ { "BOOL" "fIncUpdate" }
+ { "BYTE[32]" "rgbReserved" }
+;
C-STRUCT: BITMAPINFOHEADER
{ "DWORD" "biSize" }
{ "LONG" "x" }
{ "LONG" "y" } ;
+C-STRUCT: SIZE
+ { "LONG" "cx" }
+ { "LONG" "cy" } ;
+
C-STRUCT: MSG
{ "HWND" "hWnd" }
{ "UINT" "message" }
{ "LONG" "right" }
{ "LONG" "bottom" } ;
+: <RECT> ( loc dim -- RECT )
+ over v+
+ "RECT" <c-object>
+ over first over set-RECT-right
+ swap second over set-RECT-bottom
+ over first over set-RECT-left
+ swap second over set-RECT-top ;
+
TYPEDEF: RECT* PRECT
TYPEDEF: RECT* LPRECT
TYPEDEF: PIXELFORMATDESCRIPTOR PFD
{ "WORD" "key" }
{ "WORD" "cmd" } ;
TYPEDEF: ACCEL* LPACCEL
+
+TYPEDEF: DWORD COLORREF
+TYPEDEF: DWORD* LPCOLORREF
+
+: RGB ( r g b -- COLORREF )
+ { 16 8 0 } bitfield ; inline
+
+: color>RGB ( color -- COLORREF )
+ >rgba-components drop [ 255 * >integer ] tri@ RGB ;
+
+C-STRUCT: TEXTMETRICW
+ { "LONG" "tmHeight" }
+ { "LONG" "tmAscent" }
+ { "LONG" "tmDescent" }
+ { "LONG" "tmInternalLeading" }
+ { "LONG" "tmExternalLeading" }
+ { "LONG" "tmAveCharWidth" }
+ { "LONG" "tmMaxCharWidth" }
+ { "LONG" "tmWeight" }
+ { "LONG" "tmOverhang" }
+ { "LONG" "tmDigitizedAspectX" }
+ { "LONG" "tmDigitizedAspectY" }
+ { "WCHAR" "tmFirstChar" }
+ { "WCHAR" "tmLastChar" }
+ { "WCHAR" "tmDefaultChar" }
+ { "WCHAR" "tmBreakChar" }
+ { "BYTE" "tmItalic" }
+ { "BYTE" "tmUnderlined" }
+ { "BYTE" "tmStruckOut" }
+ { "BYTE" "tmPitchAndFamily" }
+ { "BYTE" "tmCharSet" } ;
+
+TYPEDEF: TEXTMETRICW* LPTEXTMETRIC
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+High-level wrapper around Uniscribe binding\r
--- /dev/null
+unportable\r
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel assocs math sequences fry io.encodings.string
+io.encodings.utf16n accessors arrays combinators destructors
+cache namespaces init fonts alien.c-types windows windows.usp10
+windows.offscreen windows.gdi32 windows.ole32 windows.types
+windows.fonts opengl.textures locals ;
+IN: windows.uniscribe
+
+TUPLE: script-string font string metrics ssa size image disposed ;
+
+: line-offset>x ( n script-string -- x )
+ 2dup string>> length = [
+ ssa>> ! ssa
+ swap 1- ! icp
+ TRUE ! fTrailing
+ ] [
+ ssa>>
+ swap ! icp
+ FALSE ! fTrailing
+ ] if
+ 0 <int> [ ScriptStringCPtoX ole32-error ] keep *int ;
+
+: x>line-offset ( x script-string -- n trailing )
+ ssa>> ! ssa
+ swap ! iX
+ 0 <int> ! pCh
+ 0 <int> ! piTrailing
+ [ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ;
+
+<PRIVATE
+
+: make-script-string ( dc string -- script-string )
+ dup selection? [ string>> ] when
+ [ utf16n encode ] ! pString
+ [ length ] bi ! cString
+ dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
+ -1 ! iCharset -- Unicode
+ SSA_GLYPHS ! dwFlags
+ 0 ! iReqWidth
+ f ! psControl
+ f ! psState
+ f ! piDx
+ f ! pTabdef
+ f ! pbInClass
+ f <void*> ! pssa
+ [ ScriptStringAnalyse ] keep
+ [ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
+
+: set-dc-colors ( dc font -- )
+ [ background>> color>RGB SetBkColor drop ]
+ [ foreground>> color>RGB SetTextColor drop ] 2bi ;
+
+: selection-start/end ( script-string -- iMinSel iMaxSel )
+ string>> dup selection? [ [ start>> ] [ end>> ] bi ] [ drop 0 0 ] if ;
+
+: (draw-script-string) ( script-string -- )
+ [
+ ssa>> ! ssa
+ 0 ! iX
+ 0 ! iY
+ ETO_OPAQUE ! uOptions
+ ]
+ [ [ { 0 0 } ] dip size>> <RECT> ]
+ [ selection-start/end ] tri
+ ! iMinSel
+ ! iMaxSel
+ FALSE ! fDisabled
+ ScriptStringOut ole32-error ;
+
+: draw-script-string ( dc script-string -- )
+ [ font>> set-dc-colors ] keep (draw-script-string) ;
+
+:: make-script-string-image ( dc script-string -- image )
+ script-string size>> dc
+ [ dc script-string draw-script-string ] make-bitmap-image ;
+
+: set-dc-font ( dc font -- )
+ cache-font SelectObject win32-error=0/f ;
+
+: script-string-size ( script-string -- dim )
+ ssa>> ScriptString_pSize
+ dup win32-error=0/f
+ [ SIZE-cx ] [ SIZE-cy ] bi 2array ;
+
+: dc-metrics ( dc -- metrics )
+ "TEXTMETRICW" <c-object>
+ [ GetTextMetrics drop ] keep
+ TEXTMETRIC>metrics ;
+
+: <script-string> ( font string -- script-string )
+ [ script-string new ] 2dip
+ [ >>font ] [ >>string ] bi*
+ [
+ {
+ [ over font>> set-dc-font ]
+ [ dc-metrics >>metrics ]
+ [ over string>> make-script-string >>ssa ]
+ [ drop dup script-string-size >>size ]
+ [ over make-script-string-image >>image ]
+ } cleave
+ ] with-memory-dc ;
+
+PRIVATE>
+
+M: script-string dispose*
+ ssa>> <void*> ScriptStringFree ole32-error ;
+
+SYMBOL: cached-script-strings
+
+: cached-script-string ( font string -- script-string )
+ cached-script-strings get-global [ <script-string> ] 2cache ;
+
+[ <cache-assoc> cached-script-strings set-global ]
+"windows.uniscribe" add-init-hook
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax alien.destructors ;
IN: windows.usp10
LIBRARY: usp10
SCRIPT_STRING_ANALYSIS* pssa
) ;
+DESTRUCTOR: ScriptStringFree
+
FUNCTION: SIZE* ScriptString_pSize ( SCRIPT_STRING_ANALYSIS ssa ) ;
FUNCTION: int* ScriptString_pcOutChars ( SCRIPT_STRING_ANALYSIS ssa ) ;
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax alien.c-types alien.strings arrays
-combinators kernel math namespaces parser prettyprint sequences
+combinators kernel math namespaces parser sequences
windows.errors windows.types windows.kernel32 words
io.encodings.utf16n ;
IN: windows
{ [ lines>> car 1list? ] [ top-fits? ] } 1|| ;
:: min-by ( seq quot -- elt )
- f 1.0/0.0 seq [| key value new |
+ f 1/0. seq [| key value new |
new quot call :> newvalue
newvalue value < [ new newvalue ] [ key value ] if
] each drop ; inline
IN: x11.windows
: create-window-mask ( -- n )
- { CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ;
+ { CWColormap CWEventMask } flags ;
: create-colormap ( visinfo -- colormap )
- dpy get root get rot XVisualInfo-visual AllocNone
+ [ dpy get root get ] dip XVisualInfo-visual AllocNone
XCreateColormap ;
: event-mask ( -- n )
: window-attributes ( visinfo -- attributes )
"XSetWindowAttributes" <c-object>
- 0 over set-XSetWindowAttributes-background_pixel
- 0 over set-XSetWindowAttributes-border_pixel
[ [ create-colormap ] dip set-XSetWindowAttributes-colormap ] keep
event-mask over set-XSetWindowAttributes-event_mask ;
+++ /dev/null
-libcairo-2.dll
-libgio-2.0-0.dll
-libglib-2.0-0.dll
-libgmodule-2.0-0.dll
-libgobject-2.0-0.dll
-libgthread-2.0-0.dll
-libpango-1.0-0.dll
-libpangocairo-1.0-0.dll
-libpangowin32-1.0-0.dll
-libpng12-0.dll
-libtiff3.dll
-zlib1.dll
}
check_X11_libraries() {
- check_library_exists GLU
check_library_exists GL
check_library_exists X11
check_library_exists pango-1.0
write_test_program() {
echo "#include <stdio.h>" > $C_WORD.c
- echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
+ echo "int main(){printf(\"%ld\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
}
c_find_word_size() {
check_ret $DOWNLOADER
}
-maybe_download_dlls() {
- if [[ $OS == winnt ]] ; then
- for file in `cat build-support/dlls.txt`; do
- get_url http://factorcode.org/dlls/$file
- chmod 777 *.dll
- check_ret chmod
- done
- fi
-}
-
get_config_info() {
find_build_info
check_installed_programs
cd_factor
make_factor
get_boot_image
- maybe_download_dlls
bootstrap
}
}
install_build_system_apt() {
- sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
+ sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev wget git-core git-doc rlwrap gcc make
check_ret sudo
}
update) update; update_bootstrap ;;
bootstrap) get_config_info; bootstrap ;;
report) find_build_info ;;
- dlls) get_config_info; maybe_download_dlls;;
net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;;
*) usage ;;
USING: accessors alien alien.accessors alien.syntax byte-arrays arrays
kernel kernel.private namespaces tools.test sequences libc math
-system prettyprint layouts alien.libraries ;
+system prettyprint layouts alien.libraries sets ;
IN: alien.tests
[ t ] [ -1 <alien> alien-address 0 > ] unit-test
[ ] [ initialize-test get BAD-ALIEN >>alien drop ] unit-test
[ 7575 ] [ initialize-test [ 7575 ] initialize-alien ] unit-test
+
+[ V{ BAD-ALIEN } ] [ { BAD-ALIEN BAD-ALIEN BAD-ALIEN } prune ] unit-test
\ No newline at end of file
2drop f
] if ;
+M: simple-alien hashcode* nip dup expired>> [ drop 1234 ] [ alien-address ] if ;
+
ERROR: alien-callback-error ;
: alien-callback ( return parameters abi quot -- alien )
{ "fputc" "io.streams.c" (( ch alien -- )) }
{ "fwrite" "io.streams.c" (( string alien -- )) }
{ "fflush" "io.streams.c" (( alien -- )) }
+ { "fseek" "io.streams.c" (( alien offset whence -- )) }
{ "fclose" "io.streams.c" (( alien -- )) }
{ "<wrapper>" "kernel" (( obj -- wrapper )) }
{ "(clone)" "kernel" (( obj -- newobj )) }
"W{"
"["
"\\"
+ "M\\"
"]"
"delimiter"
"f"
[
builtins get sift [ (flatten-class) ] each
] [
- unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
+ [ ] [ assoc-intersect ] map-reduce [ swap set ] assoc-each
] if-empty ;
M: anonymous-complement (flatten-class)
[ forget ] [ drop ] if
] [ 2drop ] if ;
-: forget-methods ( class -- )
- [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
+GENERIC: forget-methods ( class -- )
GENERIC: class-forgotten ( use class -- )
$nl
"Constructors play a part in enforcing the invariant that slot values must always match slot declarations. The " { $link new } " word fills in the tuple with initial values, and " { $link boa } " ensures that the values on the stack match the corresponding slot declarations. See " { $link "tuple-declarations" } "."
$nl
-"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers."
+"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construct a different class, without breaking callers."
$nl
"Examples of constructors:"
{ $code
" <employee> \"project manager\" >>position ;" }
"An alternative strategy is to define the most general BOA constructor first:"
{ $code
- ": <employee> ( name position -- person )"
+ ": <employee> ( name position -- employee )"
" 40000 employee boa ;"
}
"Now we can define more specific constructors:"
{ $code
- ": <manager> ( name -- person )"
- " \"manager\" <person> ;" }
+ ": <manager> ( name -- employee )"
+ " \"manager\" <employee> ;" }
"An example using reader words:"
{ $code
"TUPLE: check to amount number ;"
": next-position ( role -- newrole )"
" positions [ index 1+ ] keep nth ;"
""
- ": promote ( person -- person )"
+ ": promote ( employee -- employee )"
" [ 1.2 * ] change-salary"
" [ next-position ] change-position ;"
}
[
[ ] [ \ forget-robustness-generic forget ] unit-test
[ ] [ \ forget-robustness forget ] unit-test
- [ ] [ { forget-robustness forget-robustness-generic } forget ] unit-test
+ [ ] [ M\ forget-robustness forget-robustness-generic forget ] unit-test
] with-compilation-unit
! rapido found this one
GENERIC: break-me ( obj -- )
-[ ] [ [ { integer break-me } forget ] with-compilation-unit ] unit-test
+[ ] [ [ M\ integer break-me forget ] with-compilation-unit ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval ] unit-test
effects words ;
IN: combinators
+ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators"
+"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "."
+$nl
+"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:"
+{ $code
+ ": keep [ ] bi ;"
+ ": 2keep [ ] 2bi ;"
+ ": 3keep [ ] 3bi ;"
+ ""
+ ": dup [ ] [ ] bi ;"
+ ": 2dup [ ] [ ] 2bi ;"
+ ": 3dup [ ] [ ] 3bi ;"
+ ""
+ ": tuck [ nip ] [ ] 2bi ;"
+ ": swap [ nip ] [ drop ] 2bi ;"
+ ""
+ ": over [ ] [ drop ] 2bi ;"
+ ": pick [ ] [ 2drop ] 3bi ;"
+ ": 2over [ ] [ drop ] 3bi ;"
+} ;
+
+ARTICLE: "cleave-combinators" "Cleave combinators"
+"The cleave combinators apply multiple quotations to a single value."
+$nl
+"Two quotations:"
+{ $subsection bi }
+{ $subsection 2bi }
+{ $subsection 3bi }
+"Three quotations:"
+{ $subsection tri }
+{ $subsection 2tri }
+{ $subsection 3tri }
+"An array of quotations:"
+{ $subsection cleave }
+{ $subsection 2cleave }
+{ $subsection 3cleave }
+"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:"
+{ $code
+ "! First alternative; uses keep"
+ "[ 1 + ] keep"
+ "[ 1 - ] keep"
+ "2 *"
+ "! Second alternative: uses tri"
+ "[ 1 + ]"
+ "[ 1 - ]"
+ "[ 2 * ] tri"
+}
+"The latter is more aesthetically pleasing than the former."
+{ $subsection "cleave-shuffle-equivalence" } ;
+
+ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
+"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", " { $link tri* } ", and " { $link 2tri* } "."
+$nl
+"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:"
+{ $code
+ ": dip [ ] bi* ;"
+ ": 2dip [ ] [ ] tri* ;"
+ ""
+ ": slip [ call ] [ ] bi* ;"
+ ": 2slip [ call ] [ ] [ ] tri* ;"
+ ""
+ ": nip [ drop ] [ ] bi* ;"
+ ": 2nip [ drop ] [ drop ] [ ] tri* ;"
+ ""
+ ": rot"
+ " [ [ drop ] [ ] [ drop ] tri* ]"
+ " [ [ drop ] [ drop ] [ ] tri* ]"
+ " [ [ ] [ drop ] [ drop ] tri* ]"
+ " 3tri ;"
+ ""
+ ": -rot"
+ " [ [ drop ] [ drop ] [ ] tri* ]"
+ " [ [ ] [ drop ] [ drop ] tri* ]"
+ " [ [ drop ] [ ] [ drop ] tri* ]"
+ " 3tri ;"
+ ""
+ ": spin"
+ " [ [ drop ] [ drop ] [ ] tri* ]"
+ " [ [ drop ] [ ] [ drop ] tri* ]"
+ " [ [ ] [ drop ] [ drop ] tri* ]"
+ " 3tri ;"
+} ;
+
+ARTICLE: "spread-combinators" "Spread combinators"
+"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading."
+$nl
+"Two quotations:"
+{ $subsection bi* }
+{ $subsection 2bi* }
+"Three quotations:"
+{ $subsection tri* }
+{ $subsection 2tri* }
+"An array of quotations:"
+{ $subsection spread }
+"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
+{ $code
+ "! First alternative; uses dip"
+ "[ [ 1 + ] dip 1 - ] dip 2 *"
+ "! Second alternative: uses tri*"
+ "[ 1 + ] [ 1 - ] [ 2 * ] tri*"
+}
+"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
+{ $subsection "spread-shuffle-equivalence" } ;
+
+ARTICLE: "apply-combinators" "Apply combinators"
+"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application."
+$nl
+"Two quotations:"
+{ $subsection bi@ }
+{ $subsection 2bi@ }
+"Three quotations:"
+{ $subsection tri@ }
+{ $subsection 2tri@ }
+"A pair of utility words built from " { $link bi@ } ":"
+{ $subsection both? }
+{ $subsection either? } ;
+
+ARTICLE: "slip-keep-combinators" "Retain stack combinators"
+"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators."
+$nl
+"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
+{ $subsection dip }
+{ $subsection 2dip }
+{ $subsection 3dip }
+{ $subsection 4dip }
+"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
+{ $subsection slip }
+{ $subsection 2slip }
+{ $subsection 3slip }
+"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
+{ $subsection keep }
+{ $subsection 2keep }
+{ $subsection 3keep } ;
+
+ARTICLE: "curried-dataflow" "Curried dataflow combinators"
+"Curried cleave combinators:"
+{ $subsection bi-curry }
+{ $subsection tri-curry }
+"Curried spread combinators:"
+{ $subsection bi-curry* }
+{ $subsection tri-curry* }
+"Curried apply combinators:"
+{ $subsection bi-curry@ }
+{ $subsection tri-curry@ }
+{ $see-also "dataflow-combinators" } ;
+
+ARTICLE: "compositional-examples" "Examples of compositional combinator usage"
+"Consider printing the same message ten times:"
+{ $code ": print-10 ( -- ) 10 [ \"Hello, world.\" print ] times ;" }
+"if we wanted to abstract out the message into a parameter, we could keep it on the stack between iterations:"
+{ $code ": print-10 ( message -- ) 10 [ dup print ] times drop ;" }
+"However, keeping loop-invariant values on the stack doesn't always work out nicely. For example, a word to subtract a value from each element of a sequence:"
+{ $code ": subtract-n ( seq n -- seq' ) swap [ over - ] map nip ;" }
+"Three shuffle words are required to pass the value around. Instead, the loop-invariant value can be partially applied to a quotation using " { $link curry } ", yielding a new quotation that is passed to " { $link map } ":"
+{ $example
+ "USING: kernel math prettyprint sequences ;"
+ ": subtract-n ( seq n -- seq' ) [ - ] curry map ;"
+ "{ 10 20 30 } 5 subtract-n ."
+ "{ 5 15 25 }"
+}
+"Now consider the word that is dual to the one above; instead of subtracting " { $snippet "n" } " from each stack element, it subtracts each element from " { $snippet "n" } "."
+$nl
+"One way to write this is with a pair of " { $link swap } "s:"
+{ $code ": n-subtract ( n seq -- seq' ) swap [ swap - ] curry map ;" }
+"Since this pattern comes up often, " { $link with } " encapsulates it:"
+{ $example
+ "USING: kernel math prettyprint sequences ;"
+ ": n-subtract ( n seq -- seq' ) [ - ] with map ;"
+ "30 { 10 20 30 } n-subtract ."
+ "{ 20 10 0 }"
+}
+{ $see-also "fry.examples" } ;
+
+ARTICLE: "compositional-combinators" "Compositional combinators"
+"Certain combinators transform quotations to produce a new quotation."
+{ $subsection "compositional-examples" }
+"Fundamental operations:"
+{ $subsection curry }
+{ $subsection compose }
+"Derived operations:"
+{ $subsection 2curry }
+{ $subsection 3curry }
+{ $subsection with }
+{ $subsection prepose }
+"These operations run in constant time, and in many cases are optimized out altogether by the " { $link "compiler" } ". " { $link "fry" } " are an abstraction built on top of these operations, and code that uses this abstraction is often clearer than direct calls to the below words."
+$nl
+"Curried dataflow combinators can be used to build more complex dataflow by combining cleave, spread and apply patterns in various ways."
+{ $subsection "curried-dataflow" }
+"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } ". However, such runtime quotation manipulation will not be optimized by the optimizing compiler." ;
+
+ARTICLE: "booleans" "Booleans"
+"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."
+{ $subsection f }
+{ $subsection t }
+"There are some logical operations on booleans:"
+{ $subsection >boolean }
+{ $subsection not }
+{ $subsection and }
+{ $subsection or }
+{ $subsection xor }
+"Boolean values are most frequently used for " { $link "conditionals" } "."
+{ $heading "The f object and f class" }
+"The " { $link f } " object is the unique instance of the " { $link f } " class; the two are distinct objects. The latter is also a parsing word which adds the " { $link f } " object to the parse tree at parse time. To refer to the class itself you must use " { $link POSTPONE: POSTPONE: } " or " { $link POSTPONE: \ } " to prevent the parsing word from executing."
+$nl
+"Here is the " { $link f } " object:"
+{ $example "f ." "f" }
+"Here is the " { $link f } " class:"
+{ $example "\\ f ." "POSTPONE: f" }
+"They are not equal:"
+{ $example "f \\ f = ." "f" }
+"Here is an array containing the " { $link f } " object:"
+{ $example "{ f } ." "{ f }" }
+"Here is an array containing the " { $link f } " class:"
+{ $example "{ POSTPONE: f } ." "{ POSTPONE: f }" }
+"The " { $link f } " object is an instance of the " { $link f } " class:"
+{ $example "USE: classes" "f class ." "POSTPONE: f" }
+"The " { $link f } " class is an instance of " { $link word } ":"
+{ $example "USE: classes" "\\ f class ." "word" }
+"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of."
+{ $example "t \\ t eq? ." "t" }
+"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
+
+ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic"
+"Certain simple conditional forms can be expressed in a simpler manner using boolean logic."
+$nl
+"The following two lines are equivalent:"
+{ $code "[ drop f ] unless" "swap and" }
+"The following two lines are equivalent:"
+{ $code "[ ] [ ] ?if" "swap or" }
+"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
+{ $code "[ L ] unless*" "L or" } ;
+
+ARTICLE: "conditionals" "Conditional combinators"
+"The basic conditionals:"
+{ $subsection if }
+{ $subsection when }
+{ $subsection unless }
+"Forms abstracting a common stack shuffle pattern:"
+{ $subsection if* }
+{ $subsection when* }
+{ $subsection unless* }
+"Another form abstracting a common stack shuffle pattern:"
+{ $subsection ?if }
+"Sometimes instead of branching, you just need to pick one of two values:"
+{ $subsection ? }
+"Two combinators which abstract out nested chains of " { $link if } ":"
+{ $subsection cond }
+{ $subsection case }
+{ $subsection "conditionals-boolean-equivalence" }
+{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
+
+ARTICLE: "dataflow-combinators" "Data flow combinators"
+"Data flow combinators pass values between quotations:"
+{ $subsection "slip-keep-combinators" }
+{ $subsection "cleave-combinators" }
+{ $subsection "spread-combinators" }
+{ $subsection "apply-combinators" }
+{ $see-also "curried-dataflow" } ;
+
ARTICLE: "combinators-quot" "Quotation construction utilities"
"Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:"
{ $subsection cond>quot }
{ $subsection case>quot }
{ $subsection alist>quot } ;
-ARTICLE: "call" "Calling code with known stack effects"
-"Arbitrary quotations and words can be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate."
+ARTICLE: "call" "Fundamental combinators"
+"The most basic combinators are those that take either a quotation or word, and invoke it immediately. There are two sets of combinators; they differe in whether or not the stack effect of the expected code is declared."
$nl
-"Quotations:"
-{ $subsection POSTPONE: call( }
+"The simplest combinators do not take an effect declaration:"
+{ $subsection call }
+{ $subsection execute }
+"These combinators only get optimized by the compiler if the quotation or word parameter is a literal; otherwise a compiler warning will result. Definitions of combinators which require literal parameters must be followed by the " { $link POSTPONE: inline } " declaration. For example:"
+{ $code
+ ": keep ( x quot -- x )"
+ " over [ call ] dip ; inline"
+}
+"See " { $link "declarations" } " and " { $link "compiler-errors" } " for details."
+$nl
+"The other set of combinators allow arbitrary quotations and words to be called from optimized code. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate."
{ $subsection call-effect }
-"Words:"
-{ $subsection POSTPONE: execute( }
{ $subsection execute-effect }
-"Unsafe calls:"
+"A simple layer of syntax sugar is defined on top:"
+{ $subsection POSTPONE: call( }
+{ $subsection POSTPONE: execute( }
+"Unsafe calls declare an effect statically without any runtime checking:"
{ $subsection call-effect-unsafe }
-{ $subsection execute-effect-unsafe } ;
+{ $subsection execute-effect-unsafe }
+{ $see-also "effects" "inference" } ;
-ARTICLE: "combinators" "Additional combinators"
-"The " { $vocab-link "combinators" } " vocabulary provides a few useful combinators."
+ARTICLE: "combinators" "Combinators"
+"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
+{ $subsection "call" }
+{ $subsection "dataflow-combinators" }
+{ $subsection "conditionals" }
+{ $subsection "looping-combinators" }
+{ $subsection "compositional-combinators" }
+{ $subsection "combinators.short-circuit" }
+{ $subsection "combinators.smart" }
+"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "."
$nl
-"Generalization of " { $link bi } " and " { $link tri } ":"
-{ $subsection cleave }
-"Generalization of " { $link 2bi } " and " { $link 2tri } ":"
-{ $subsection 2cleave }
-"Generalization of " { $link 3bi } " and " { $link 3tri } ":"
-{ $subsection 3cleave }
-"Generalization of " { $link bi* } " and " { $link tri* } ":"
-{ $subsection spread }
-"Two combinators which abstract out nested chains of " { $link if } ":"
-{ $subsection cond }
-{ $subsection case }
-"The " { $vocab-link "combinators" } " also provides some less frequently-used features."
+"The " { $vocab-link "combinators" } " provides some less frequently-used features."
$nl
"A combinator which can help with implementing methods on " { $link hashcode* } ":"
{ $subsection recursive-hashcode }
-{ $subsection "call" }
{ $subsection "combinators-quot" }
-{ $see-also "quotations" "dataflow" } ;
+"Advanced topics:"
+{ $see-also "quotations" } ;
ABOUT: "combinators"
{ $subsection redefine-error } ;
ARTICLE: "definitions" "Definitions"
-"A " { $emphasis "definition" } " is an artifact read from a source file. This includes words, methods, help articles, and path names (which represent the source file at that location). Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary."
+"A " { $emphasis "definition" } " is an artifact read from a source file. Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary."
+$nl
+"Definitions are defined using parsing words. Examples of definitions together with their defining parsing words are words (" { $link POSTPONE: : } "), methods (" { $link POSTPONE: M: } "), and vocabularies (" { $link POSTPONE: IN: } ")."
+$nl
+"All definitions share some common traits:"
+{ $list
+ "There is a word to list all definitions of a given type"
+ "There is a parsing word for creating new definitions"
+ "There is an ordinary word which is the runtime equivalent of the parsing word, for introspection"
+ "Instances of the definition may be introspected and modified with the definition protocol"
+}
+"For every source file loaded into the system, a list of definitions is maintained. Pathname objects implement the definition protocol, acting over the definitions their source files contain. See " { $link "source-files" } " for details."
{ $subsection "definition-protocol" }
{ $subsection "definition-crossref" }
{ $subsection "definition-checking" }
{ $subsection "compilation-units" }
+"A parsing word to remove definitions:"
+{ $subsection POSTPONE: FORGET: }
{ $see-also "see" "parser" "source-files" "words" "generic" "help-impl" } ;
ABOUT: "definitions"
M: some-class some-generic ;
-TUPLE: another-class some-generic ;
-
[ ] [
[
- {
- some-generic
- some-class
- { another-class some-generic }
- } forget-all
+ \ some-generic
+ \ some-class
+ 2array
+ forget-all
] with-compilation-unit
] unit-test
GENERIC: forget* ( defspec -- )
-M: object forget* drop ;
+M: f forget* drop ;
SYMBOL: forgotten-definitions
: forget-all ( definitions -- ) [ forget ] each ;
-GENERIC: synopsis* ( defspec -- )
-
GENERIC: definer ( defspec -- start end )
GENERIC: definition ( defspec -- seq )
-USING: help.markup help.syntax math strings words kernel ;
+USING: help.markup help.syntax math strings words kernel combinators ;
IN: effects
ARTICLE: "effect-declaration" "Stack effect declaration"
"The stack effect inferencer verifies stack effect comments to ensure the correct number of inputs and outputs is listed. Value names are ignored; only their number matters. An error is thrown if a word's declared stack effect does not match its inferred stack effect. See " { $link "inference" } "." ;
ARTICLE: "effects" "Stack effects"
-"A " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that an operation takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output."
+"A " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that an operation takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effects are first-class, and words for working with them are found in the " { $vocab-link "effects" } " vocabulary."
$nl
-"Stack effects of words can be declared."
+"Stack effects of words must be declared, and the " { $link "compiler" } " checks that these declarations are correct. Invalid declarations are reported as " { $link "compiler-errors" } ". The " { $link "inference" } " tool can be used to check stack effects interactively."
{ $subsection "effect-declaration" }
-"Stack effects are first-class, and words for working with them are found in the " { $vocab-link "effects" } " vocabulary."
-{ $subsection effect }
-{ $subsection effect? }
-"There is a literal syntax for stack objects. It is most often used with " { $link define-declared } "."
+"There is a literal syntax for stack objects. It is most often used with " { $link define-declared } ", " { $link call-effect } " and " { $link execute-effect } "."
{ $subsection POSTPONE: (( }
"Getting a word's declared stack effect:"
{ $subsection stack-effect }
"Comparing effects:"
{ $subsection effect-height }
{ $subsection effect<= }
-{ $see-also "inference" } ;
+"The class of stack effects:"
+{ $subsection effect }
+{ $subsection effect? } ;
ABOUT: "effects"
{ $subsection make-generic }
"Low-level method constructor:"
{ $subsection <method> }
-"A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":"
-{ $subsection method-spec }
+"Methods may be pushed on the stack with a literal syntax:"
+{ $subsection POSTPONE: M\ }
{ $see-also "see" } ;
ARTICLE: "method-combination" "Custom method combination"
"Generic words must declare their stack effect in order to compile. See " { $link "effect-declaration" } "."
{ $subsection "method-order" }
{ $subsection "call-next-method" }
-{ $subsection "generic-introspection" }
{ $subsection "method-combination" }
+{ $subsection "generic-introspection" }
"Generic words specialize behavior based on the class of an object; sometimes behavior needs to be specialized on the object's " { $emphasis "structure" } "; this is known as " { $emphasis "pattern matching" } " and is implemented in the " { $vocab-link "match" } " vocabulary." ;
ABOUT: "generic"
{ $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." }
{ $contract "The method combination quotation is called each time the generic word has to be updated (for example, when a method is added), and thus must be side-effect free." } ;
-HELP: method-spec
-{ $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." }
-{ $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ;
+HELP: M\
+{ $syntax "M\\ class generic" }
+{ $class-description "Pushes a method on the stack." }
+{ $examples { $code "M\\ fixnum + see" } { $code "USING: ui.gadgets ui.gadgets.editors ;" "M\\ editor draw-gadget* edit" } } ;
HELP: method-body
{ $class-description "The class of method bodies, which are words with special word properties set." } ;
[ float ] [ \ real \ float math-class-max ] unit-test
[ fixnum ] [ \ fixnum \ null math-class-max ] unit-test
-[ t ] [ { hashtable equal? } method-spec? ] unit-test
-[ f ] [ { word = } method-spec? ] unit-test
-
! Regression
TUPLE: first-one ;
TUPLE: second-one ;
] unit-test
[ ] [
- [ { sequence generic-forget-test-2 } forget ] with-compilation-unit
+ [ M\ sequence generic-forget-test-2 forget ] with-compilation-unit
] unit-test
[ f ] [
[ 3 ] [ 2 c-n-m-cache ] unit-test
-[ ] [ [ { integer c-n-m-cache } forget ] with-compilation-unit ] unit-test
+[ ] [ [ M\ integer c-n-m-cache forget ] with-compilation-unit ] unit-test
[ 2 ] [ 2 c-n-m-cache ] unit-test
: method ( class generic -- method/f )
"methods" word-prop at ;
-PREDICATE: method-spec < pair
- first2 generic? swap class? and ;
-
-INSTANCE: method-spec definition
-
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
PREDICATE: method-body < word
"method-generic" word-prop >boolean ;
-M: method-spec stack-effect
- first2 method stack-effect ;
-
M: method-body stack-effect
"method-generic" word-prop stack-effect ;
dupd <default-method> "default-method" set-word-prop ;
! Definition protocol
-M: method-spec where
- dup first2 method [ ] [ second ] ?if where ;
-
-M: method-spec set-where
- first2 method set-where ;
-
-M: method-spec definer
- first2 method definer ;
-
-M: method-spec definition
- first2 method definition ;
-
-M: method-spec forget*
- first2 method [ forgotten-definition ] [ forget* ] bi ;
-
-M: method-spec smart-usage
- second smart-usage ;
-
M: method-body definer
drop \ M: \ ; ;
M: generic forget*
[ subwords forget-all ] [ call-next-method ] bi ;
+M: class forget-methods
+ [ implementors ] [ [ swap method ] curry ] bi map forget-all ;
+
: xref-generics ( -- )
all-words [ subwords [ xref ] each ] each ;
HELP: math-method
{ $values { "word" generic } { "class1" class } { "class2" class } { "quot" quotation } }
{ $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." }
-{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ { fixnum float } declare [ >float ] dip float=>+ ]" } } ;
+{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ { fixnum float } declare [ >float ] dip M\\ float + ]" } } ;
HELP: math-class
{ $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ;
"An encoding descriptor is something which can be used with binary input or output streams to encode or decode bytes stored in a certain representation. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:"
{ $subsection "io.encodings.binary" }
{ $subsection "io.encodings.utf8" }
-{ $subsection "io.encodings.utf16" }
+{ $vocab-subsection "UTF-16 encoding" "io.encodings.utf16" }
{ $vocab-subsection "UTF-32 encoding" "io.encodings.utf32" }
{ $vocab-subsection "Strict encodings" "io.encodings.strict" }
"Legacy encodings:"
{ $vocab-subsection "8-bit encodings" "io.encodings.8-bit" }
-{ $vocab-subsection "ASCII" "io.encodings.ascii" }
+{ $vocab-subsection "ASCII encoding" "io.encodings.ascii" }
{ $see-also "encodings-introduction" } ;
ARTICLE: "encodings-protocol" "Encoding protocol"
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private namespaces make io io.encodings
sequences math generic threads.private classes io.backend
-io.files continuations destructors byte-arrays accessors ;
+io.files continuations destructors byte-arrays accessors
+combinators ;
IN: io.streams.c
-TUPLE: c-writer handle disposed ;
+TUPLE: c-stream handle disposed ;
+
+M: c-stream dispose* handle>> fclose ;
+
+M: c-stream stream-seek
+ handle>> swap {
+ { seek-absolute [ 0 ] }
+ { seek-relative [ 1 ] }
+ { seek-end [ 2 ] }
+ [ bad-seek-type ]
+ } case fseek ;
+
+TUPLE: c-writer < c-stream ;
: <c-writer> ( handle -- stream ) f c-writer boa ;
M: c-writer stream-flush dup check-disposed handle>> fflush ;
-M: c-writer dispose* handle>> fclose ;
-
-TUPLE: c-reader handle disposed ;
+TUPLE: c-reader < c-stream ;
: <c-reader> ( handle -- stream ) f c-reader boa ;
[ swap read-until-loop ] B{ } make swap
over empty? over not and [ 2drop f f ] when ;
-M: c-reader dispose*
- handle>> fclose ;
-
M: c-io-backend init-io ;
: stdin-handle ( -- alien ) 11 getenv ;
{ $subsection roll }
{ $subsection -roll } ;
-ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators"
-"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "."
-$nl
-"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:"
-{ $code
- ": keep [ ] bi ;"
- ": 2keep [ ] 2bi ;"
- ": 3keep [ ] 3bi ;"
- ""
- ": dup [ ] [ ] bi ;"
- ": 2dup [ ] [ ] 2bi ;"
- ": 3dup [ ] [ ] 3bi ;"
- ""
- ": tuck [ nip ] [ ] 2bi ;"
- ": swap [ nip ] [ drop ] 2bi ;"
- ""
- ": over [ ] [ drop ] 2bi ;"
- ": pick [ ] [ 2drop ] 3bi ;"
- ": 2over [ ] [ drop ] 3bi ;"
-} ;
-
-ARTICLE: "cleave-combinators" "Cleave combinators"
-"The cleave combinators apply multiple quotations to a single value."
-$nl
-"Two quotations:"
-{ $subsection bi }
-{ $subsection 2bi }
-{ $subsection 3bi }
-"Three quotations:"
-{ $subsection tri }
-{ $subsection 2tri }
-{ $subsection 3tri }
-"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:"
-{ $code
- "! First alternative; uses keep"
- "[ 1 + ] keep"
- "[ 1 - ] keep"
- "2 *"
- "! Second alternative: uses tri"
- "[ 1 + ]"
- "[ 1 - ]"
- "[ 2 * ] tri"
-}
-"The latter is more aesthetically pleasing than the former."
-$nl
-"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
-{ $subsection "cleave-shuffle-equivalence" } ;
-
-ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
-"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", " { $link tri* } ", and " { $link 2tri* } "."
-$nl
-"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:"
-{ $code
- ": dip [ ] bi* ;"
- ": 2dip [ ] [ ] tri* ;"
- ""
- ": slip [ call ] [ ] bi* ;"
- ": 2slip [ call ] [ ] [ ] tri* ;"
- ""
- ": nip [ drop ] [ ] bi* ;"
- ": 2nip [ drop ] [ drop ] [ ] tri* ;"
- ""
- ": rot"
- " [ [ drop ] [ ] [ drop ] tri* ]"
- " [ [ drop ] [ drop ] [ ] tri* ]"
- " [ [ ] [ drop ] [ drop ] tri* ]"
- " 3tri ;"
- ""
- ": -rot"
- " [ [ drop ] [ drop ] [ ] tri* ]"
- " [ [ ] [ drop ] [ drop ] tri* ]"
- " [ [ drop ] [ ] [ drop ] tri* ]"
- " 3tri ;"
- ""
- ": spin"
- " [ [ drop ] [ drop ] [ ] tri* ]"
- " [ [ drop ] [ ] [ drop ] tri* ]"
- " [ [ ] [ drop ] [ drop ] tri* ]"
- " 3tri ;"
-} ;
-
-ARTICLE: "spread-combinators" "Spread combinators"
-"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading."
-$nl
-"Two quotations:"
-{ $subsection bi* }
-{ $subsection 2bi* }
-"Three quotations:"
-{ $subsection tri* }
-{ $subsection 2tri* }
-"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
-{ $code
- "! First alternative; uses dip"
- "[ [ 1 + ] dip 1 - ] dip 2 *"
- "! Second alternative: uses tri*"
- "[ 1 + ] [ 1 - ] [ 2 * ] tri*"
-}
-"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
-{ $subsection "spread-shuffle-equivalence" } ;
-
-ARTICLE: "apply-combinators" "Apply combinators"
-"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application."
-$nl
-"Two quotations:"
-{ $subsection bi@ }
-{ $subsection 2bi@ }
-"Three quotations:"
-{ $subsection tri@ }
-{ $subsection 2tri@ }
-"A pair of utility words built from " { $link bi@ } ":"
-{ $subsection both? }
-{ $subsection either? } ;
-
-ARTICLE: "slip-keep-combinators" "Retain stack combinators"
-"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators."
-$nl
-"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
-{ $subsection dip }
-{ $subsection 2dip }
-{ $subsection 3dip }
-{ $subsection 4dip }
-"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
-{ $subsection slip }
-{ $subsection 2slip }
-{ $subsection 3slip }
-"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
-{ $subsection keep }
-{ $subsection 2keep }
-{ $subsection 3keep } ;
-
-ARTICLE: "curried-dataflow" "Curried dataflow combinators"
-"Curried cleave combinators:"
-{ $subsection bi-curry }
-{ $subsection tri-curry }
-"Curried spread combinators:"
-{ $subsection bi-curry* }
-{ $subsection tri-curry* }
-"Curried apply combinators:"
-{ $subsection bi-curry@ }
-{ $subsection tri-curry@ }
-{ $see-also "dataflow-combinators" } ;
-
-ARTICLE: "compositional-examples" "Examples of compositional combinator usage"
-"Consider printing the same message ten times:"
-{ $code ": print-10 ( -- ) 10 [ \"Hello, world.\" print ] times ;" }
-"if we wanted to abstract out the message into a parameter, we could keep it on the stack between iterations:"
-{ $code ": print-10 ( message -- ) 10 [ dup print ] times drop ;" }
-"However, keeping loop-invariant values on the stack doesn't always work out nicely. For example, a word to subtract a value from each element of a sequence:"
-{ $code ": subtract-n ( seq n -- seq' ) swap [ over - ] map nip ;" }
-"Three shuffle words are required to pass the value around. Instead, the loop-invariant value can be partially applied to a quotation using " { $link curry } ", yielding a new quotation that is passed to " { $link map } ":"
-{ $example
- "USING: kernel math prettyprint sequences ;"
- ": subtract-n ( seq n -- seq' ) [ - ] curry map ;"
- "{ 10 20 30 } 5 subtract-n ."
- "{ 5 15 25 }"
-}
-"Now consider the word that is dual to the one above; instead of subtracting " { $snippet "n" } " from each stack element, it subtracts each element from " { $snippet "n" } "."
-$nl
-"One way to write this is with a pair of " { $link swap } "s:"
-{ $code ": n-subtract ( n seq -- seq' ) swap [ swap - ] curry map ;" }
-"Since this pattern comes up often, " { $link with } " encapsulates it:"
-{ $example
- "USING: kernel math prettyprint sequences ;"
- ": n-subtract ( n seq -- seq' ) [ - ] with map ;"
- "30 { 10 20 30 } n-subtract ."
- "{ 20 10 0 }"
-}
-{ $see-also "fry.examples" } ;
-
-ARTICLE: "compositional-combinators" "Compositional combinators"
-"Certain combinators transform quotations to produce a new quotation."
-{ $subsection "compositional-examples" }
-"Fundamental operations:"
-{ $subsection curry }
-{ $subsection compose }
-"Derived operations:"
-{ $subsection 2curry }
-{ $subsection 3curry }
-{ $subsection with }
-{ $subsection prepose }
-"These operations run in constant time, and in many cases are optimized out altogether by the " { $link "compiler" } ". " { $link "fry" } " are an abstraction built on top of these operations, and code that uses this abstraction is often clearer than direct calls to the below words."
-$nl
-"Curried dataflow combinators can be used to build more complex dataflow by combining cleave, spread and apply patterns in various ways."
-{ $subsection "curried-dataflow" }
-"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } ". However, such runtime quotation manipulation will not be optimized by the optimizing compiler." ;
-
-ARTICLE: "implementing-combinators" "Implementing combinators"
-"The following pair of words invoke words and quotations reflectively:"
-{ $subsection call }
-{ $subsection execute }
-"These words are used to implement combinators. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:"
-{ $code
- ": keep ( x quot -- x )"
- " over [ call ] dip ; inline"
-}
-"Word inlining is documented in " { $link "declarations" } "." ;
-
-ARTICLE: "booleans" "Booleans"
-"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."
-{ $subsection f }
-{ $subsection t }
-"The " { $link f } " object is the unique instance of the " { $link f } " class; the two are distinct objects. The latter is also a parsing word which adds the " { $link f } " object to the parse tree at parse time. To refer to the class itself you must use " { $link POSTPONE: POSTPONE: } " or " { $link POSTPONE: \ } " to prevent the parsing word from executing."
-$nl
-"Here is the " { $link f } " object:"
-{ $example "f ." "f" }
-"Here is the " { $link f } " class:"
-{ $example "\\ f ." "POSTPONE: f" }
-"They are not equal:"
-{ $example "f \\ f = ." "f" }
-"Here is an array containing the " { $link f } " object:"
-{ $example "{ f } ." "{ f }" }
-"Here is an array containing the " { $link f } " class:"
-{ $example "{ POSTPONE: f } ." "{ POSTPONE: f }" }
-"The " { $link f } " object is an instance of the " { $link f } " class:"
-{ $example "USE: classes" "f class ." "POSTPONE: f" }
-"The " { $link f } " class is an instance of " { $link word } ":"
-{ $example "USE: classes" "\\ f class ." "word" }
-"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of."
-{ $example "t \\ t eq? ." "t" }
-"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
-
-ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic"
-"Certain simple conditional forms can be expressed in a simpler manner using boolean logic."
-$nl
-"The following two lines are equivalent:"
-{ $code "[ drop f ] unless" "swap and" }
-"The following two lines are equivalent:"
-{ $code "[ ] [ ] ?if" "swap or" }
-"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
-{ $code "[ L ] unless*" "L or" } ;
-
-ARTICLE: "conditionals" "Conditionals and logic"
-"The basic conditionals:"
-{ $subsection if }
-{ $subsection when }
-{ $subsection unless }
-"Forms abstracting a common stack shuffle pattern:"
-{ $subsection if* }
-{ $subsection when* }
-{ $subsection unless* }
-"Another form abstracting a common stack shuffle pattern:"
-{ $subsection ?if }
-"Sometimes instead of branching, you just need to pick one of two values:"
-{ $subsection ? }
-"There are some logical operations on booleans:"
-{ $subsection >boolean }
-{ $subsection not }
-{ $subsection and }
-{ $subsection or }
-{ $subsection xor }
-{ $subsection "conditionals-boolean-equivalence" }
-"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
-{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
-
ARTICLE: "equality" "Equality"
"There are two distinct notions of “sameness” when it comes to objects."
$nl
{ $subsection assert }
{ $subsection assert= } ;
-ARTICLE: "dataflow-combinators" "Data flow combinators"
-"Data flow combinators pass values between quotations:"
-{ $subsection "slip-keep-combinators" }
-{ $subsection "cleave-combinators" }
-{ $subsection "spread-combinators" }
-{ $subsection "apply-combinators" }
-{ $see-also "curried-dataflow" } ;
-
-ARTICLE: "dataflow" "Data and control flow"
-{ $subsection "evaluator" }
-{ $subsection "words" }
-{ $subsection "effects" }
-{ $subsection "booleans" }
-{ $subsection "shuffle-words" }
-"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
-{ $subsection "dataflow-combinators" }
-{ $subsection "conditionals" }
-{ $subsection "looping-combinators" }
-{ $subsection "compositional-combinators" }
-{ $subsection "combinators" }
-"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "."
-$nl
-"Advanced topics:"
-{ $subsection "assertions" }
-{ $subsection "implementing-combinators" }
-{ $subsection "macros" }
-{ $subsection "errors" }
-{ $subsection "continuations" } ;
-
-ABOUT: "dataflow"
-
[ t ] [ 0.0 zero? ] unit-test
[ t ] [ -0.0 zero? ] unit-test
-! [ f ] [ 0.0/0.0 0.0/0.0 number= ] unit-test
-
[ 0 ] [ 1/0. >bignum ] unit-test
[ t ] [ 64 [ 2^ 0.5 * ] map [ < ] monotonic? ] unit-test
2drop 0.0
] [
dup zero? [
- 2drop 1.0/0.0
+ 2drop 1/0.
] [
pre-scale
/f-loop over odd?
{ $subsection 2/ }
{ $subsection 2^ }
{ $subsection bit? }
-"The " { $vocab-link "math.bitwise" } " vocabulary implements additional bitwise integer operations."
-{ $see-also "conditionals" } ;
+{ $subsection "math.bitwise" }
+{ $subsection "math.bits" }
+{ $see-also "booleans" } ;
ARTICLE: "arithmetic" "Arithmetic"
"Factor attempts to preserve natural mathematical semantics for numbers. Multiplying two large integers never results in overflow, and dividing two integers yields an exact ratio. Floating point numbers are also supported, along with complex numbers."
{ $subsection +lt+ }
{ $subsection +eq+ }
{ $subsection +gt+ } ;
-
+
+ARTICLE: "math.order.example" "Linear order example"
+"A tuple class which defines an ordering among instances by comparing the values of the " { $snippet "id" } " slot:"
+{ $code
+ "TUPLE: sprite id name bitmap ;"
+ "M: sprite <=> [ id>> ] compare ;"
+} ;
+
ARTICLE: "math.order" "Linear order protocol"
"Some classes have an intrinsic order amongst instances:"
{ $subsection <=> }
{ $subsection before? }
{ $subsection after=? }
{ $subsection before=? }
+"Out of the above generic words, it suffices to implement " { $link <=> } " alone. The others may be provided as an optimization."
+{ $subsection "math.order.example" }
{ $see-also "sequences-sorting" } ;
ABOUT: "math.order"
ABOUT: "number-strings"
HELP: digits>integer
-{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n" integer } }
+{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n/f" { $maybe integer } } }
{ $description "Converts a sequence of digits (with most significant digit first) into an integer." }
{ $notes "This is one of the factors of " { $link string>number } "." } ;
[ 1 0 >base ] must-fail
[ 1 -1 >base ] must-fail
-[ "0.0/0.0" ] [ 0.0 0.0 / number>string ] unit-test
+[ "0/0." ] [ 0.0 0.0 / number>string ] unit-test
-[ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test
+[ "1/0." ] [ 1.0 0.0 / number>string ] unit-test
-[ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test
+[ "-1/0." ] [ -1.0 0.0 / number>string ] unit-test
[ t ] [ "0/0." string>number fp-nan? ] unit-test
-[ 1.0/0.0 ] [ "1/0." string>number ] unit-test
+[ 1/0. ] [ "1/0." string>number ] unit-test
-[ -1.0/0.0 ] [ "-1/0." string>number ] unit-test
+[ -1/0. ] [ "-1/0." string>number ] unit-test
[ "-0.0" ] [ -0.0 number>string ] unit-test
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math.private namespaces sequences strings
-arrays combinators splitting math assocs make ;
+USING: kernel math.private namespaces sequences sequences.private
+strings arrays combinators splitting math assocs make ;
IN: math.parser
: digit> ( ch -- n )
{ CHAR: d 13 }
{ CHAR: e 14 }
{ CHAR: f 15 }
- } at ;
+ } at 255 or ; inline
: string>digits ( str -- digits )
- [ digit> ] { } map-as ;
+ [ digit> ] B{ } map-as ; inline
-: digits>integer ( seq radix -- n )
- 0 swap [ swapd * + ] curry reduce ;
+: (digits>integer) ( valid? accum digit radix -- valid? accum )
+ 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline
+
+: each-digit ( seq radix quot -- n/f )
+ [ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
+
+: digits>integer ( seq radix -- n/f )
+ [ (digits>integer) ] each-digit ; inline
DEFER: base>
SYMBOL: radix
SYMBOL: negative?
+: string>natural ( seq radix -- n/f )
+ over empty? [ 2drop f ] [
+ [ [ digit> ] dip (digits>integer) ] each-digit
+ ] if ; inline
+
: sign ( -- str ) negative? get "-" "+" ? ;
: with-radix ( radix quot -- )
sign split1 [ (base>) ] dip
dup [ (base>) ] [ drop 0 swap ] if ;
-: string>ratio ( str -- a/b )
- "-" ?head dup negative? set swap
- "/" split1 (base>) [ whole-part ] dip
- 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ;
-
-: valid-digits? ( seq -- ? )
- {
- { [ dup empty? ] [ drop f ] }
- { [ f over memq? ] [ drop f ] }
- [ radix get [ < ] curry all? ]
- } cond ;
+: string>ratio ( str radix -- a/b )
+ [
+ "-" ?head dup negative? set swap
+ "/" split1 (base>) [ whole-part ] dip
+ 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if
+ ] with-radix ;
-: string>integer ( str -- n/f )
- "-" ?head swap
- string>digits dup valid-digits?
- [ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ;
+: string>integer ( str radix -- n/f )
+ over first-unsafe CHAR: - = [
+ [ rest-slice ] dip string>natural dup [ neg ] when
+ ] [
+ string>natural
+ ] if ; inline
PRIVATE>
: base> ( str radix -- n/f )
- [
- CHAR: / over member? [
- string>ratio
- ] [
- CHAR: . over member? [
- string>float
- ] [
- string>integer
- ] if
- ] if
- ] with-radix ;
+ over empty? [ 2drop f ] [
+ over [ "/." member? ] find nip {
+ { CHAR: / [ string>ratio ] }
+ { CHAR: . [ drop string>float ] }
+ [ drop string>integer ]
+ } case
+ ] if ;
: string>number ( str -- n/f ) 10 base> ;
: bin> ( str -- n/f ) 2 base> ;
M: float >base
drop {
- { [ dup fp-nan? ] [ drop "0.0/0.0" ] }
- { [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
- { [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }
+ { [ dup fp-nan? ] [ drop "0/0." ] }
+ { [ dup 1/0. = ] [ drop "1/0." ] }
+ { [ dup -1/0. = ] [ drop "-1/0." ] }
{ [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] }
[ float>string fix-float ]
} cond ;
{ $subsection >n }
{ $subsection ndrop } ;
-ARTICLE: "namespaces" "Variables and namespaces"
+ARTICLE: "namespaces" "Dynamic variables and namespaces"
"The " { $vocab-link "namespaces" } " vocabulary implements simple dynamically-scoped variables."
$nl
"A variable is an entry in an assoc of bindings, where the assoc is implicit rather than passed on the stack. These assocs are termed " { $emphasis "namespaces" } ". Nesting of scopes is implemented with a search order on namespaces, defined by a " { $emphasis "namestack" } ". Since namespaces are just assoc, any object can be used as a variable, however by convention, variables are keyed by symbols (see " { $link "words.symbol" } ")."
"Various utility words abstract away common variable access patterns:"
{ $subsection "namespaces-change" }
{ $subsection "namespaces-combinators" }
-{ $subsection "namespaces-global" }
"Implementation details your code probably does not care about:"
{ $subsection "namespaces.private" }
"An alternative to dynamic scope is lexical scope. Lexically-scoped values and closures are implemented in the " { $vocab-link "locals" } " vocabulary." ;
"This parser is a general facility for reading textual representations of objects and definitions. The parser is implemented in the " { $vocab-link "parser" } " and " { $vocab-link "syntax" } " vocabularies."
$nl
"This section concerns itself with usage and extension of the parser. Standard syntax is described in " { $link "syntax" } "."
-{ $subsection "vocabulary-search" }
{ $subsection "parser-files" }
-{ $subsection "top-level-forms" }
"The parser can be extended."
{ $subsection "parsing-words" }
{ $subsection "parser-lexer" }
"Wrappers are used to push words on the data stack; they evaluate to the object being wrapped:"
{ $subsection wrapper }
{ $subsection literalize }
-{ $see-also "dataflow" "combinators" } ;
+{ $see-also "combinators" } ;
ABOUT: "quotations"
HELP: map-index
{ $values
- { "seq" sequence } { "quot" quotation } }
+ { "seq" sequence } { "quot" quotation } { "newseq" sequence } }
{ $description "Calls the quotation with the element of the sequence and its index on the stack, with the index on the top of the stack. Collects the outputs of the quotation and outputs them in a sequence of the same type as the input sequence." }
{ $examples { $example "USING: sequences prettyprint math ;"
"{ 10 20 30 } [ + ] map-index ."
"Virtual sequences allow different ways of accessing a sequence without having to create a new sequence or a new data structure altogether. To do this, they translate the virtual index into a normal index into an underlying sequence using the " { $link "virtual-sequences-protocol" } "."
{ $subsection "virtual-sequences-protocol" } ;
-ARTICLE: "sequences-integers" "Integer sequences and counted loops"
+ARTICLE: "sequences-integers" "Counted loops"
"Integers support the sequence protocol in a trivial fashion; a non-negative integer presents its non-negative predecessors as elements. For example, the integer 3, when viewed as a sequence, contains the elements 0, 1, and 2. This is very useful for performing counted loops."
$nl
"For example, the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:"
{ $example "3 [ . ] each" "0\n1\n2" }
"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link each-index } ", " { $link map-index } " and " { $link reduce-index } "."
$nl
-"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer." ;
+"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer."
+$nl
+"More elaborate counted loops can be performed with " { $link "math.ranges" } "." ;
ARTICLE: "sequences-access" "Accessing sequence elements"
{ $subsection ?nth }
"Sequences implement a protocol:"
{ $subsection "sequence-protocol" }
{ $subsection "sequences-f" }
-{ $subsection "sequences-integers" }
"Sequence utility words can operate on any object whose class implements the sequence protocol. Most implementations are backed by storage. Some implementations obtain their elements from an underlying sequence, or compute them on the fly. These are known as " { $link "virtual-sequences" } "."
{ $subsection "sequences-access" }
{ $subsection "sequences-combinators" }
{ $subsection "binary-search" }
{ $subsection "sets" }
{ $subsection "sequences-trimming" }
+{ $subsection "sequences.deep" }
+"Using sequences for looping:"
+{ $subsection "sequences-integers" }
+{ $subsection "math.ranges" }
"For inner loops:"
{ $subsection "sequences-unsafe" } ;
[ -3 10 nth ] must-fail
[ 11 10 nth ] must-fail
-[ -1./0. 0 delete-nth ] must-fail
+[ -1/0. 0 delete-nth ] must-fail
[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
[ "" ] [ "" [ CHAR: \s = ] trim-head ] unit-test
[ "" ] [ "" [ CHAR: \s = ] trim-tail ] unit-test
[ [ 0 = ] 2dip if ] 2curry
each-index ; inline
-: map-index ( seq quot -- )
+: map-index ( seq quot -- newseq )
prepare-index 2map ; inline
: reduce-index ( seq identity quot -- )
"A word can be used to check if a class has an initial value or not:"
{ $subsection initial-value } ;
-ARTICLE: "slots" "Slots"
+ARTICLE: "slots" "Low-level slot operations"
"The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object. A " { $emphasis "slot" } " is a component of an object which can store a value."
$nl
{ $link "tuples" } " are composed entirely of slots, and instances of " { $link "builtin-classes" } " consist of slots together with intrinsic data."
{ $subsection define-changer }
{ $subsection define-slot-methods }
{ $subsection define-accessors }
+"Unsafe slot access:"
+{ $subsection slot }
+{ $subsection set-slot }
{ $see-also "accessors" "mirrors" } ;
ABOUT: "slots"
"7.e13"
"1.0e-5"
}
+"There are three special float values:"
+{ $table
+{ "Positive infinity" { $snippet "1/0." } }
+{ "Negative infinity" { $snippet "-1/0." } }
+{ "Not-a-number" { $snippet "0/0." } }
+}
"More information on floats can be found in " { $link "floats" } "." ;
ARTICLE: "syntax-complex-numbers" "Complex number syntax"
ARTICLE: "syntax" "Syntax"
"Factor has two main forms of syntax: " { $emphasis "definition" } " syntax and " { $emphasis "literal" } " syntax. Code is data, so the syntax for code is a special case of object literal syntax. This section documents literal syntax. Definition syntax is covered in " { $link "words" } ". Extending the parser is the main topic of " { $link "parser" } "."
{ $subsection "parser-algorithm" }
+{ $subsection "vocabulary-search" }
+{ $subsection "top-level-forms" }
{ $subsection "syntax-comments" }
{ $subsection "syntax-literals" }
{ $subsection "syntax-immediate" } ;
{ $description "Marks the end of a parse time code block." } ;
HELP: call-next-method
+{ $syntax "call-next-method" }
{ $description "Calls the next applicable method. Only valid inside a method definition. The values at the top of the stack are passed on to the next method, and they must be compatible with that method's class specializer." }
+{ $notes "This word looks like an ordinary word but it is a parsing word. It cannot be factored out of a method definition, since the code expansion references the current method object directly." }
{ $errors
"Throws a " { $link no-next-method } " error if this is the least specific method, and throws an " { $link inconsistent-next-method } " error if the values at the top of the stack are not compatible with the current method's specializer."
} ;
"POSTPONE:" [ scan-word parsed ] define-core-syntax
"\\" [ scan-word <wrapper> parsed ] define-core-syntax
+ "M\\" [ scan-word scan-word method <wrapper> parsed ] define-core-syntax
"inline" [ word make-inline ] define-core-syntax
"recursive" [ word make-recursive ] define-core-syntax
"foldable" [ word make-foldable ] define-core-syntax
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: quotations effects accessors sequences words kernel ;
+USING: quotations effects accessors sequences words kernel definitions ;
IN: words.alias
PREDICATE: alias < word "alias" word-prop ;
M: alias reset-word
[ call-next-method ] [ f "alias" set-word-prop ] bi ;
-M: alias stack-effect
- def>> first stack-effect ;
+M: alias definer drop \ ALIAS: f ;
+
+M: alias definition def>> first 1quotation ;
\ No newline at end of file
--- /dev/null
+IN: words.constant.tests
+USING: tools.test math words.constant ;
+
+CONSTANT: a +
+
+[ + ] [ a ] unit-test
+
+[ t ] [ \ a constant? ] unit-test
+
+CONSTANT: b \ +
+
+[ \ + ] [ b ] unit-test
+
+CONSTANT: c { 1 2 3 }
+
+[ { 1 2 3 } ] [ c ] unit-test
+
+SYMBOL: foo
+
+[ f ] [ \ foo constant? ] unit-test
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences words ;
+USING: accessors kernel sequences words definitions quotations ;
IN: words.constant
-PREDICATE: constant < word ( obj -- ? )
- def>> dup length 1 = [ first word? not ] [ drop f ] if ;
+PREDICATE: constant < word "constant" word-prop >boolean ;
: define-constant ( word value -- )
- [ ] curry (( -- value )) define-inline ;
+ [ "constant" set-word-prop ]
+ [ [ ] curry (( -- value )) define-inline ] 2bi ;
+
+M: constant reset-word
+ [ call-next-method ] [ f "constant" set-word-prop ] bi ;
+
+M: constant definer drop \ CONSTANT: f ;
+
+M: constant definition "constant" word-prop literalize 1quotation ;
\ No newline at end of file
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors definitions
-words words.constant ;
+USING: kernel sequences accessors definitions words ;
IN: words.symbol
-PREDICATE: symbol < constant ( obj -- ? )
+PREDICATE: symbol < word ( obj -- ? )
[ def>> ] [ [ ] curry ] bi sequence= ;
M: symbol definer drop \ SYMBOL: f ;
M: symbol definition drop f ;
: define-symbol ( word -- )
- dup define-constant ;
+ dup [ ] curry (( -- value )) define-inline ;
-USING: kernel namespaces math.vectors opengl 4DNav.turtle ;
+USING: kernel namespaces math.vectors opengl opengl.glu 4DNav.turtle ;
IN: 4DNav.camera
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string assocs
+heaps.private ;
+IN: assoc-heaps
+
+HELP: <assoc-heap>
+{ $values { "assoc" assoc } { "heap" heap } { "assoc-heap" assoc-heap } }
+{ $description "Constructs a new " { $link assoc-heap } " from two existing data structures." } ;
+
+HELP: <unique-max-heap>
+{ $values { "unique-heap" assoc-heap } }
+{ $description "Creates a new " { $link assoc-heap } " where the assoc is a hashtable and the heap is a max-heap. Popping an element from the heap leaves this element in the hashtable to ensure that the element will not be processed again." } ;
+
+HELP: <unique-min-heap>
+{ $values { "unique-heap" assoc-heap } }
+{ $description "Creates a new " { $link assoc-heap } " where the assoc is a hashtable and the heap is a min-heap. Popping an element from the heap leaves this element in the hashtable to ensure that the element will not be processed again." } ;
+
+{ <unique-max-heap> <unique-min-heap> } related-words
+
+HELP: assoc-heap
+{ $description "A data structure containing an assoc and a heap to get certain properties with better time constraints at the expense of more space and complexity. For instance, a hashtable and a heap can be combined into one assoc-heap to get a sorted data structure with O(1) lookup. Operations on assoc-heap may update both the assoc and the heap or leave them out of sync if it's advantageous." } ;
+
+ARTICLE: "assoc-heaps" "Associative heaps"
+"The " { $vocab-link "assoc-heaps" } " vocabulary combines exists to synthesize data structures with better time properties than either of the two component data structures alone." $nl
+"Associative heap constructor:"
+{ $subsection <assoc-heap> }
+"Unique heaps:"
+{ $subsection <unique-min-heap> }
+{ $subsection <unique-max-heap> } ;
+
+ABOUT: "assoc-heaps"
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test assoc-heaps ;
+IN: assoc-heaps.tests
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs hashtables heaps kernel ;
+IN: assoc-heaps
+
+TUPLE: assoc-heap assoc heap ;
+
+C: <assoc-heap> assoc-heap
+
+: <unique-min-heap> ( -- unique-heap )
+ H{ } clone <min-heap> <assoc-heap> ;
+
+: <unique-max-heap> ( -- unique-heap )
+ H{ } clone <max-heap> <assoc-heap> ;
+
+M: assoc-heap heap-push* ( value key assoc-heap -- entry )
+ pick over assoc>> key? [
+ 3drop f
+ ] [
+ [ assoc>> swapd set-at ] [ heap>> heap-push* ] 3bi
+ ] if ;
+
+M: assoc-heap heap-pop ( assoc-heap -- value key )
+ heap>> heap-pop ;
+
+M: assoc-heap heap-peek ( assoc-heap -- value key )
+ heap>> heap-peek ;
+
+M: assoc-heap heap-empty? ( assoc-heap -- value key )
+ heap>> heap-empty? ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Priority queue with fast insertion, removal of first element, and lookup of arbitrary elements by key
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-name "benchmark.fib6" }
+ { deploy-threads? f }
+ { deploy-math? f }
+ { deploy-word-props? f }
+ { deploy-ui? f }
+ { deploy-io 1 }
+ { deploy-compiler? t }
+ { deploy-reflection 1 }
+ { "stop-after-last-window?" t }
+ { deploy-unicode? f }
+ { deploy-word-defs? f }
+ { deploy-c-types? f }
+}
: sphere-t ( b d -- t )
-+ dup 0.0 <
- [ 2drop 1.0/0.0 ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
+ [ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
: sphere-b&v ( sphere ray -- b v )
[ sphere-v ] [ nip ] 2bi
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test c.preprocessor kernel accessors multiline ;
+IN: c.preprocessor.tests
+
+[ "vocab:c/tests/test1/test1.c" start-preprocess-file ]
+[ include-nested-too-deeply? ] must-fail-with
+
+[ "yo\n\n\n\nyo4\n" ]
+[ "vocab:c/tests/test2/test2.c" start-preprocess-file nip ] unit-test
+
+/*
+[ "vocab:c/tests/test3/test3.c" start-preprocess-file ]
+[ "\"BOO\"" = ] must-fail-with
+*/
+
+[ V{ "\"omg\"" "\"lol\"" } ]
+[ "vocab:c/tests/test4/test4.c" start-preprocess-file drop warnings>> ] unit-test
+
+
+/*
+f(2 * (y+1)) + f(2 * (f(2 * (z[0])))) % f(2 * (0)) + t(1);
+f(2 * (2+(3,4)-0,1)) | f(2 * (~ 5)) & f(2 * (0,1))^m(0,1);
+int i[] = { 1, 23, 4, 5, };
+char c[2][6] = { "hello", "" };
+*/
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequence-parser io io.encodings.utf8 io.files
+io.streams.string kernel combinators accessors io.pathnames
+fry sequences arrays locals namespaces io.directories
+assocs math splitting make unicode.categories
+combinators.short-circuit ;
+IN: c.preprocessor
+
+: initial-library-paths ( -- seq )
+ V{ "/usr/include" } clone ;
+
+: initial-symbol-table ( -- hashtable )
+ H{
+ { "__APPLE__" "" }
+ { "__amd64__" "" }
+ { "__x86_64__" "" }
+ } clone ;
+
+TUPLE: preprocessor-state library-paths symbol-table
+include-nesting include-nesting-max processing-disabled?
+ifdef-nesting warnings errors
+pragmas
+include-nexts
+ifs elifs elses ;
+
+: <preprocessor-state> ( -- preprocessor-state )
+ preprocessor-state new
+ initial-library-paths >>library-paths
+ initial-symbol-table >>symbol-table
+ 0 >>include-nesting
+ 200 >>include-nesting-max
+ 0 >>ifdef-nesting
+ V{ } clone >>warnings
+ V{ } clone >>errors
+ V{ } clone >>pragmas
+ V{ } clone >>include-nexts
+ V{ } clone >>ifs
+ V{ } clone >>elifs
+ V{ } clone >>elses ;
+
+DEFER: preprocess-file
+
+ERROR: unknown-c-preprocessor sequence-parser name ;
+
+ERROR: bad-include-line line ;
+
+ERROR: header-file-missing path ;
+
+:: read-standard-include ( preprocessor-state path -- )
+ preprocessor-state dup library-paths>>
+ [ path append-path exists? ] find nip
+ [
+ dup [
+ path append-path
+ preprocess-file
+ ] with-directory
+ ] [
+ ! path header-file-missing
+ drop
+ ] if* ;
+
+:: read-local-include ( preprocessor-state path -- )
+ current-directory get path append-path dup :> full-path
+ dup exists? [
+ [ preprocessor-state ] dip preprocess-file
+ ] [
+ ! full-path header-file-missing
+ drop
+ ] if ;
+
+: skip-whitespace/comments ( sequence-parser -- sequence-parser )
+ skip-whitespace
+ {
+ { [ dup take-c-comment ] [ skip-whitespace/comments ] }
+ { [ dup take-c++-comment ] [ skip-whitespace/comments ] }
+ [ ]
+ } cond ;
+
+: handle-include ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments advance dup previous {
+ { CHAR: < [ CHAR: > take-until-object read-standard-include ] }
+ { CHAR: " [ CHAR: " take-until-object read-local-include ] }
+ [ bad-include-line ]
+ } case ;
+
+: (readlns) ( -- )
+ readln "\\" ?tail [ , ] dip [ (readlns) ] when ;
+
+: readlns ( -- string ) [ (readlns) ] { } make concat ;
+
+: take-define-identifier ( sequence-parser -- string )
+ skip-whitespace/comments
+ [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
+
+: handle-define ( preprocessor-state sequence-parser -- )
+ [ take-define-identifier ]
+ [ skip-whitespace/comments take-rest ] bi
+ "\\" ?tail [ readlns append ] when
+ spin symbol-table>> set-at ;
+
+: handle-undef ( preprocessor-state sequence-parser -- )
+ take-token swap symbol-table>> delete-at ;
+
+: handle-ifdef ( preprocessor-state sequence-parser -- )
+ [ [ 1 + ] change-ifdef-nesting ] dip
+ take-token over symbol-table>> key?
+ [ drop ] [ t >>processing-disabled? drop ] if ;
+
+: handle-ifndef ( preprocessor-state sequence-parser -- )
+ [ [ 1 + ] change-ifdef-nesting ] dip
+ take-token over symbol-table>> key?
+ [ t >>processing-disabled? drop ]
+ [ drop ] if ;
+
+: handle-endif ( preprocessor-state sequence-parser -- )
+ drop [ 1 - ] change-ifdef-nesting drop ;
+
+: handle-if ( preprocessor-state sequence-parser -- )
+ [ [ 1 + ] change-ifdef-nesting ] dip
+ skip-whitespace/comments take-rest swap ifs>> push ;
+
+: handle-elif ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap elifs>> push ;
+
+: handle-else ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap elses>> push ;
+
+: handle-pragma ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap pragmas>> push ;
+
+: handle-include-next ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap include-nexts>> push ;
+
+: handle-error ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap errors>> push ;
+ ! nip take-rest throw ;
+
+: handle-warning ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments
+ take-rest swap warnings>> push ;
+
+: parse-directive ( preprocessor-state sequence-parser string -- )
+ {
+ { "warning" [ handle-warning ] }
+ { "error" [ handle-error ] }
+ { "include" [ handle-include ] }
+ { "define" [ handle-define ] }
+ { "undef" [ handle-undef ] }
+ { "ifdef" [ handle-ifdef ] }
+ { "ifndef" [ handle-ifndef ] }
+ { "endif" [ handle-endif ] }
+ { "if" [ handle-if ] }
+ { "elif" [ handle-elif ] }
+ { "else" [ handle-else ] }
+ { "pragma" [ handle-pragma ] }
+ { "include_next" [ handle-include-next ] }
+ [ unknown-c-preprocessor ]
+ } case ;
+
+: parse-directive-line ( preprocessor-state sequence-parser -- )
+ advance dup take-token
+ pick processing-disabled?>> [
+ "endif" = [
+ drop f >>processing-disabled?
+ [ 1 - ] change-ifdef-nesting
+ drop
+ ] [ 2drop ] if
+ ] [
+ parse-directive
+ ] if ;
+
+: preprocess-line ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments dup current CHAR: # =
+ [ parse-directive-line ]
+ [ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ;
+
+: preprocess-lines ( preprocessor-state -- )
+ readln
+ [ <sequence-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
+ [ drop ] if* ;
+
+ERROR: include-nested-too-deeply ;
+
+: check-nesting ( preprocessor-state -- preprocessor-state )
+ [ 1 + ] change-include-nesting
+ dup [ include-nesting>> ] [ include-nesting-max>> ] bi > [
+ include-nested-too-deeply
+ ] when ;
+
+: preprocess-file ( preprocessor-state path -- )
+ [ check-nesting ] dip
+ [ utf8 [ preprocess-lines ] with-file-reader ]
+ [ drop [ 1 - ] change-include-nesting drop ] 2bi ;
+
+: start-preprocess-file ( path -- preprocessor-state string )
+ dup parent-directory [
+ [
+ [ <preprocessor-state> dup ] dip preprocess-file
+ ] with-string-writer
+ ] with-directory ;
--- /dev/null
+Tests if the preprocessor bails on an infinite loop caused by mutually recursive #include lines.
--- /dev/null
+#include "lo.h"
--- /dev/null
+#include "hi.h"
--- /dev/null
+#include "hi.h"
--- /dev/null
+/*
+# lol
+*/
--- /dev/null
+#define FOO_H "foo.h"
+#include FOO_H
--- /dev/null
+#if 4 > (5 - 4++)
+#error "Umm"
+#endif
--- /dev/null
+#if 10
+#error "Umm"
--- /dev/null
+#if 4 > (1 + 2)
+good
+#endif
+
+#if 4 > 1 + 2
+good
+#endif
+
+#if (4 > 1) - 1
+bad
+#endif
+
+#if (4 > 1) - 2
+good
+#endif
--- /dev/null
+Tests whether #define and #ifdef/#endif work in the positive case.
--- /dev/null
+#define YO
+#ifdef YO
+yo
+#endif
+
+#define YO2
+#ifndef YO2
+yo2
+#endif
+
+#ifdef YO3
+yo3
+#endif
+
+#ifndef YO4
+yo4
+#endif
--- /dev/null
+Tests whether #define and #ifdef/#endif work in the positive case.
--- /dev/null
+#error "BOO"
--- /dev/null
+#warning "omg"
+#warning "lol"
--- /dev/null
+#define TABSIZE 100
+
+int table[TABSIZE];
--- /dev/null
+#define max(a, b) ((a) > (b) ? (a) : (b))
--- /dev/null
+#define x 3
+#define f(a) f(x * (a))
+#undef x
+#define x 2
+#define g f
+#define z z[0]
+#define h g(~
+#define m(a) a(w)
+#define w 0,1
+#define t(a) a
+#define p() int
+#define q(x) x
+#define r(x,y) x ## y
+#define str(x) # x
+f(y+1) + f(f(z)) % t(t(g)(0) + t)(1);
+g(x+(3,4)-w) | h 5) & m
+(f)^m(m);
+p() i[q()] = { q(1), r(2,3), r(4,), r(,5), r(,) };
+char c[2][6] = { str(hello), str() };
--- /dev/null
+#define str(s) #s
+#define xstr(s) str(s)
+#define debug(s, t) printf("x" # s "= %d, x" # t "= %s", \
+x ## s, x ## t)
+#define INCFILE(n) vers ## n
+#define glue(a, b) a## b
+#define xglue(a, b) glue(a, b)
+#define HIGHLOW "hello"
+#define LOW LOW ", world"
+debug(1, 2);
+fputs(str(strncmp("abc\0d", "abc", '\4') //this goes away
+== 0) str(: @\n), s);
+#include xstr(INCFILE(2).h)
+glue(HIGH, LOW);
+xglue(HIGH, LOW)
--- /dev/null
+#define t(x,y,z) x ## y ## z
+int j[] = { t(1,2,3), t(,4,5), t(6,,7), t(8,9,),
+t(10,,), t(,11,), t(,,12), t(,,) };
+
--- /dev/null
+USING: tools.deploy.config ;
+V{
+ { deploy-ui? t }
+ { deploy-io 1 }
+ { deploy-reflection 1 }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { deploy-name "Chicago Talk" }
+}
--- /dev/null
+Slides for a talk at the Pycon VM Summit, Chicago, IL, March 2009
USING: tools.deploy.config ;
-V{
- { deploy-ui? t }
- { deploy-io 1 }
- { deploy-reflection 1 }
- { deploy-compiler? t }
- { deploy-math? t }
+H{
+ { deploy-name "Color Picker" }
{ deploy-word-props? f }
+ { deploy-ui? t }
+ { deploy-threads? t }
+ { deploy-unicode? f }
{ deploy-c-types? f }
+ { deploy-word-defs? f }
+ { deploy-compiler? t }
+ { deploy-io 2 }
+ { deploy-reflection 1 }
{ "stop-after-last-window?" t }
- { deploy-name "Color Picker" }
+ { deploy-math? t }
}
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators.smart sorting.human
-models colors.constants present
+models colors.constants present sorting.slots
ui ui.gadgets.tables ui.gadgets.scrollers ;
IN: color-table
drop named-color ;
: <color-table> ( -- table )
- named-colors human-sort <model>
+ named-colors { human<=> } sort-by <model>
color-renderer
<table>
5 >>gap
: color-table-demo ( -- )
[ <color-table> <scroller> "Colors" open-window ] with-ui ;
-MAIN: color-table-demo
\ No newline at end of file
+MAIN: color-table-demo
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test db2.connections db2.tester ;
+IN: db2.connections.tests
+
+! Tests connection
+
+{ 1 0 } [ [ ] with-db ] must-infer-as
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors destructors fry kernel namespaces ;
+IN: db2.connections
+
+TUPLE: db-connection handle ;
+
+: new-db-connection ( handle class -- db-connection )
+ new
+ swap >>handle ; inline
+
+GENERIC: db-open ( db -- db-connection )
+GENERIC: db-close ( handle -- )
+
+M: db-connection dispose ( db-connection -- )
+ [ db-close ] [ f >>handle drop ] bi ;
+
+: with-db ( db quot -- )
+ [ db-open db-connection over ] dip
+ '[ _ [ drop @ ] with-disposal ] with-variable ; inline
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test db2 kernel ;
+IN: db2.tests
+
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors continuations db2.result-sets db2.sqlite.lib
+db2.sqlite.result-sets db2.sqlite.statements db2.statements
+destructors fry kernel math namespaces sequences strings
+db2.sqlite.types ;
+IN: db2
+
+ERROR: no-in-types statement ;
+ERROR: no-out-types statement ;
+
+: guard-in ( statement -- statement )
+ dup in>> [ no-in-types ] unless ;
+
+: guard-out ( statement -- statement )
+ dup out>> [ no-out-types ] unless ;
+
+GENERIC: sql-command ( object -- )
+GENERIC: sql-query ( object -- sequence )
+GENERIC: sql-bind-command ( object -- )
+GENERIC: sql-bind-query ( object -- sequence )
+GENERIC: sql-bind-typed-command ( object -- )
+GENERIC: sql-bind-typed-query ( object -- sequence )
+
+M: string sql-command ( string -- )
+ f f <statement> sql-command ;
+
+M: string sql-query ( string -- sequence )
+ f f <statement> sql-query ;
+
+M: statement sql-command ( statement -- )
+ [ execute-statement ] with-disposal ;
+
+M: statement sql-query ( statement -- sequence )
+ [ statement>result-sequence ] with-disposal ;
+
+M: statement sql-bind-command ( statement -- )
+ [
+ guard-in
+ prepare-statement
+ [ bind-sequence ] [ statement>result-set drop ] bi
+ ] with-disposal ;
+
+M: statement sql-bind-query ( statement -- sequence )
+ [
+ guard-in
+ prepare-statement
+ [ bind-sequence ] [ statement>result-sequence ] bi
+ ] with-disposal ;
+
+M: statement sql-bind-typed-command ( statement -- )
+ [
+ guard-in
+ prepare-statement
+ [ bind-typed-sequence ] [ statement>result-set drop ] bi
+ ] with-disposal ;
+
+M: statement sql-bind-typed-query ( statement -- sequence )
+ [
+ guard-in
+ guard-out
+ prepare-statement
+ [ bind-typed-sequence ] [ statement>typed-result-sequence ] bi
+ ] with-disposal ;
+
+M: sequence sql-command [ sql-command ] each ;
+M: sequence sql-query [ sql-query ] map ;
+M: sequence sql-bind-command [ sql-bind-command ] each ;
+M: sequence sql-bind-query [ sql-bind-query ] map ;
+M: sequence sql-bind-typed-command [ sql-bind-typed-command ] each ;
+M: sequence sql-bind-typed-query [ sql-bind-typed-query ] map ;
+
+M: integer sql-command throw ;
+M: integer sql-query throw ;
+M: integer sql-bind-command throw ;
+M: integer sql-bind-query throw ;
+M: integer sql-bind-typed-command throw ;
+M: integer sql-bind-typed-query throw ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel continuations fry words constructors
+db2.connections ;
+IN: db2.errors
+
+ERROR: db-error ;
+ERROR: sql-error location ;
+HOOK: parse-sql-error db-connection ( error -- error' )
+
+ERROR: sql-unknown-error < sql-error message ;
+CONSTRUCTOR: sql-unknown-error ( message -- error ) ;
+
+ERROR: sql-table-exists < sql-error table ;
+CONSTRUCTOR: sql-table-exists ( table -- error ) ;
+
+ERROR: sql-table-missing < sql-error table ;
+CONSTRUCTOR: sql-table-missing ( table -- error ) ;
+
+ERROR: sql-syntax-error < sql-error message ;
+CONSTRUCTOR: sql-syntax-error ( message -- error ) ;
+
+ERROR: sql-function-exists < sql-error message ;
+CONSTRUCTOR: sql-function-exists ( message -- error ) ;
+
+ERROR: sql-function-missing < sql-error message ;
+CONSTRUCTOR: sql-function-missing ( message -- error ) ;
+
+: ignore-error ( quot word -- )
+ '[ dup _ execute [ drop ] [ rethrow ] if ] recover ; inline
+
+: ignore-table-exists ( quot -- )
+ \ sql-table-exists? ignore-error ; inline
+
+: ignore-table-missing ( quot -- )
+ \ sql-table-missing? ignore-error ; inline
+
+: ignore-function-exists ( quot -- )
+ \ sql-function-exists? ignore-error ; inline
+
+: ignore-function-missing ( quot -- )
+ \ sql-function-missing? ignore-error ; inline
--- /dev/null
+Errors thrown by database library
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors db2 db2.statements.tests db2.tester
+kernel tools.test db2.fql ;
+IN: db2.fql.tests
+
+: test-fql ( -- )
+ create-computer-table
+
+ [ "insert into computer (name, os) values (?, ?);" ]
+ [
+ "computer" { "name" "os" } { "lol" "os2" } <insert> expand-fql
+ sql>>
+ ] unit-test
+
+ [ "select name, os from computer" ]
+ [
+ select new
+ { "name" "os" } >>names
+ "computer" >>from
+ expand-fql sql>>
+ ] unit-test
+
+ [ "select name, os from computer group by os order by lol offset 100 limit 3" ]
+ [
+ select new
+ { "name" "os" } >>names
+ "computer" >>from
+ "os" >>group-by
+ "lol" >>order-by
+ 100 >>offset
+ 3 >>limit
+ expand-fql sql>>
+ ] unit-test
+
+ [
+ "select name, os from computer where (hmm > 1 or foo is NULL) group by os order by lol offset 100 limit 3"
+ ] [
+ select new
+ { "name" "os" } >>names
+ "computer" >>from
+ T{ or f { "hmm > 1" "foo is NULL" } } >>where
+ "os" >>group-by
+ "lol" >>order-by
+ 100 >>offset
+ 3 >>limit
+ expand-fql sql>>
+ ] unit-test
+
+ [ "delete from computer order by omg limit 3" ]
+ [
+ delete new
+ "computer" >>tables
+ "omg" >>order-by
+ 3 >>limit
+ expand-fql sql>>
+ ] unit-test
+
+ [ "update computer set name = oscar order by omg limit 3" ]
+ [
+ update new
+ "computer" >>tables
+ "name" >>keys
+ "oscar" >>values
+ "omg" >>order-by
+ 3 >>limit
+ expand-fql sql>>
+ ] unit-test
+
+ ;
+
+[ test-fql ] test-dbs
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators constructors db2
+db2.private db2.sqlite.lib db2.statements db2.utils destructors
+kernel make math.parser sequences strings assocs db2.utils ;
+IN: db2.fql
+
+GENERIC: expand-fql* ( object -- sequence/statement )
+GENERIC: normalize-fql ( object -- sequence/statement )
+
+! M: object normalize-fql ;
+
+TUPLE: insert into names values ;
+CONSTRUCTOR: insert ( into names values -- obj ) ;
+M: insert normalize-fql ( insert -- insert )
+ [ ??1array ] change-names ;
+
+TUPLE: update tables keys values where order-by limit ;
+CONSTRUCTOR: update ( tables keys values where -- obj ) ;
+M: update normalize-fql ( insert -- insert )
+ [ ??1array ] change-tables
+ [ ??1array ] change-keys
+ [ ??1array ] change-values
+ [ ??1array ] change-order-by ;
+
+TUPLE: delete tables where order-by limit ;
+CONSTRUCTOR: delete ( tables keys values where -- obj ) ;
+M: delete normalize-fql ( insert -- insert )
+ [ ??1array ] change-tables
+ [ ??1array ] change-order-by ;
+
+TUPLE: select names from where group-by order-by offset limit ;
+CONSTRUCTOR: select ( names from -- obj ) ;
+M: select normalize-fql ( select -- select )
+ [ ??1array ] change-names
+ [ ??1array ] change-from
+ [ ??1array ] change-group-by
+ [ ??1array ] change-order-by ;
+
+! TUPLE: where sequence ;
+! M: where normalize-fql ( where -- where )
+ ! [ ??1array ] change-sequence ;
+
+TUPLE: and sequence ;
+
+TUPLE: or sequence ;
+
+: expand-fql ( object1 -- object2 ) normalize-fql expand-fql* ;
+
+M: or expand-fql* ( obj -- string )
+ [
+ sequence>> "(" %
+ [ " or " % ] [ expand-fql* % ] interleave
+ ")" %
+ ] "" make ;
+
+M: and expand-fql* ( obj -- string )
+ [
+ sequence>> "(" %
+ [ " and " % ] [ expand-fql* % ] interleave
+ ")" %
+ ] "" make ;
+
+M: string expand-fql* ( string -- string ) ;
+
+M: insert expand-fql*
+ [ statement new ] dip
+ [
+ {
+ [ "insert into " % into>> % ]
+ [ " (" % names>> ", " join % ")" % ]
+ [ " values (" % values>> length "?" <array> ", " join % ");" % ]
+ [ values>> >>in ]
+ } cleave
+ ] "" make >>sql ;
+
+M: update expand-fql*
+ [ statement new ] dip
+ [
+ {
+ [ "update " % tables>> ", " join % ]
+ [
+ " set " % [ keys>> ] [ values>> ] bi
+ zip [ ", " % ] [ first2 [ % ] dip " = " % % ] interleave
+ ]
+ ! [ " " % from>> ", " join % ]
+ [ where>> [ " where " % expand-fql* % ] when* ]
+ [ order-by>> [ " order by " % ", " join % ] when* ]
+ [ limit>> [ " limit " % # ] when* ]
+ } cleave
+ ] "" make >>sql ;
+
+M: delete expand-fql*
+ [ statement new ] dip
+ [
+ {
+ [ "delete from " % tables>> ", " join % ]
+ [ where>> [ " where " % expand-fql* % ] when* ]
+ [ order-by>> [ " order by " % ", " join % ] when* ]
+ [ limit>> [ " limit " % # ] when* ]
+ } cleave
+ ] "" make >>sql ;
+
+M: select expand-fql*
+ [ statement new ] dip
+ [
+ {
+ [ "select " % names>> ", " join % ]
+ [ " from " % from>> ", " join % ]
+ [ where>> [ " where " % expand-fql* % ] when* ]
+ [ group-by>> [ " group by " % ", " join % ] when* ]
+ [ order-by>> [ " order by " % ", " join % ] when* ]
+ [ offset>> [ " offset " % # ] when* ]
+ [ limit>> [ " limit " % # ] when* ]
+ } cleave
+ ] "" make >>sql ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators constructors db2.connections
+db2.sqlite.types kernel sequence-parser sequences splitting ;
+IN: db2.introspection
+
+TUPLE: table-schema table columns ;
+CONSTRUCTOR: table-schema ( table columns -- table-schema ) ;
+
+TUPLE: column name type modifiers ;
+CONSTRUCTOR: column ( name type modifiers -- column ) ;
+
+HOOK: query-table-schema* db-connection ( name -- table-schema )
+HOOK: parse-create-statement db-connection ( name -- table-schema )
+
+: parse-column ( string -- column )
+ <sequence-parser> skip-whitespace
+ [ " " take-until-sequence ]
+ [ take-token sqlite-type>fql-type ]
+ [ take-rest ] tri <column> ;
+
+: parse-columns ( string -- seq )
+ "," split [ parse-column ] map ;
+
+M: object parse-create-statement ( string -- table-schema )
+ <sequence-parser> {
+ [ "CREATE TABLE " take-sequence* ]
+ [ "(" take-until-sequence ]
+ [ "(" take-sequence* ]
+ [ take-rest [ CHAR: ) = ] trim-tail parse-columns ]
+ } cleave <table-schema> ;
+
+: query-table-schema ( name -- table-schema )
+ query-table-schema* [ parse-create-statement ] map ;
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: accessors continuations db2.pools db2.sqlite
+db2.sqlite.connections destructors io.directories io.files
+io.files.temp kernel math namespaces tools.test
+db2.sqlite.connections ;
+IN: db2.pools.tests
+
+\ <db-pool> must-infer
+
+{ 1 0 } [ [ ] with-db-pool ] must-infer-as
+
+{ 1 0 } [ [ ] with-pooled-db ] must-infer-as
+
+! Test behavior after image save/load
+
+[ "pool-test.db" temp-file delete-file ] ignore-errors
+
+[ ] [ "pool-test.db" temp-file <sqlite-db> <db-pool> "pool" set ] unit-test
+
+[ ] [ "pool" get expired>> t >>expired drop ] unit-test
+
+[ ] [ 1000 [ "pool" get [ ] with-pooled-db ] times ] unit-test
+
+[ ] [ "pool" get dispose ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors db2.connections fry io.pools kernel
+namespaces ;
+IN: db2.pools
+
+TUPLE: db-pool < pool db ;
+
+: <db-pool> ( db -- pool )
+ db-pool <pool>
+ swap >>db ;
+
+: with-db-pool ( db quot -- )
+ [ <db-pool> ] dip with-pool ; inline
+
+M: db-pool make-connection ( pool -- )
+ db>> db-open ;
+
+: with-pooled-db ( pool quot -- )
+ '[ db-connection _ with-variable ] with-pooled-connection ; inline
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences combinators fry ;
+IN: db2.result-sets
+
+TUPLE: result-set sql in out handle n max ;
+
+GENERIC: #rows ( result-set -- n )
+GENERIC: #columns ( result-set -- n )
+GENERIC: advance-row ( result-set -- )
+GENERIC: more-rows? ( result-set -- ? )
+GENERIC# column 1 ( result-set column -- obj )
+GENERIC# column-typed 2 ( result-set column type -- sql )
+
+: init-result-set ( result-set -- result-set )
+ dup #rows >>max
+ 0 >>n ;
+
+: new-result-set ( query class -- result-set )
+ new
+ swap {
+ [ handle>> >>handle ]
+ [ sql>> >>sql ]
+ [ in>> >>in ]
+ [ out>> >>out ]
+ } cleave ;
+
+: sql-row ( result-set -- seq )
+ dup #columns [ column ] with map ;
+
+: sql-row-typed ( result-set -- seq )
+ [ #columns ] [ out>> ] [ ] tri
+ '[ [ _ ] 2dip column-typed ] 2map ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test db2.sqlite.connections ;
+IN: db2.sqlite.connections.tests
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators db2.connections db2.sqlite
+db2.sqlite.errors db2.sqlite.lib kernel db2.errors ;
+IN: db2.sqlite.connections
+
+M: sqlite-db db-open ( db -- db-connection )
+ path>> sqlite-open <sqlite-db-connection> ;
+
+M: sqlite-db-connection db-close ( db-connection -- )
+ handle>> sqlite-close ;
+
+M: sqlite-db-connection parse-sql-error ( error -- error' )
+ dup n>> {
+ { 1 [ string>> parse-sqlite-sql-error ] }
+ [ drop ]
+ } case ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors ;
+IN: db2.sqlite.db
+
+TUPLE: sqlite-db path ;
+
+: <sqlite-db> ( path -- sqlite-db )
+ sqlite-db new
+ swap >>path ;
+
+
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators db2.connections db2.errors
+db2.sqlite.ffi kernel locals namespaces peg.ebnf sequences
+strings ;
+IN: db2.sqlite.errors
+
+ERROR: sqlite-error < db-error n string ;
+ERROR: sqlite-sql-error < sql-error n string ;
+
+: sqlite-statement-error ( -- * )
+ SQLITE_ERROR
+ db-connection get handle>> sqlite3_errmsg sqlite-sql-error ;
+
+TUPLE: unparsed-sqlite-error error ;
+C: <unparsed-sqlite-error> unparsed-sqlite-error
+
+EBNF: parse-sqlite-sql-error
+
+TableMessage = " already exists"
+SyntaxError = ": syntax error"
+
+SqliteError =
+ "table " (!(TableMessage).)+:table TableMessage:message
+ => [[ table >string <sql-table-exists> ]]
+ | "near " (!(SyntaxError).)+:syntax SyntaxError:message
+ => [[ syntax >string <sql-syntax-error> ]]
+ | "no such table: " .+:table
+ => [[ table >string <sql-table-missing> ]]
+ | .*:error
+ => [[ error >string <unparsed-sqlite-error> ]]
+;EBNF
+
+: throw-sqlite-error ( n -- * )
+ dup sqlite-error-messages nth sqlite-error ;
--- /dev/null
+! Copyright (C) 2005 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+! Not all functions have been wrapped.
+USING: alien alien.libraries alien.syntax combinators system ;
+IN: db2.sqlite.ffi
+
+<< "sqlite" {
+ { [ os winnt? ] [ "sqlite3.dll" ] }
+ { [ os macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
+ { [ os unix? ] [ "libsqlite3.so" ] }
+ } cond "cdecl" add-library >>
+
+LIBRARY: sqlite
+
+! Return values from sqlite functions
+CONSTANT: SQLITE_OK 0 ! Successful result
+CONSTANT: SQLITE_ERROR 1 ! SQL error or missing database
+CONSTANT: SQLITE_INTERNAL 2 ! An internal logic error in SQLite
+CONSTANT: SQLITE_PERM 3 ! Access permission denied
+CONSTANT: SQLITE_ABORT 4 ! Callback routine requested an abort
+CONSTANT: SQLITE_BUSY 5 ! The database file is locked
+CONSTANT: SQLITE_LOCKED 6 ! A table in the database is locked
+CONSTANT: SQLITE_NOMEM 7 ! A malloc() failed
+CONSTANT: SQLITE_READONLY 8 ! Attempt to write a readonly database
+CONSTANT: SQLITE_INTERRUPT 9 ! Operation terminated by sqlite_interrupt()
+CONSTANT: SQLITE_IOERR 10 ! Some kind of disk I/O error occurred
+CONSTANT: SQLITE_CORRUPT 11 ! The database disk image is malformed
+CONSTANT: SQLITE_NOTFOUND 12 ! (Internal Only) Table or record not found
+CONSTANT: SQLITE_FULL 13 ! Insertion failed because database is full
+CONSTANT: SQLITE_CANTOPEN 14 ! Unable to open the database file
+CONSTANT: SQLITE_PROTOCOL 15 ! Database lock protocol error
+CONSTANT: SQLITE_EMPTY 16 ! (Internal Only) Database table is empty
+CONSTANT: SQLITE_SCHEMA 17 ! The database schema changed
+CONSTANT: SQLITE_TOOBIG 18 ! Too much data for one row of a table
+CONSTANT: SQLITE_CONSTRAINT 19 ! Abort due to contraint violation
+CONSTANT: SQLITE_MISMATCH 20 ! Data type mismatch
+CONSTANT: SQLITE_MISUSE 21 ! Library used incorrectly
+CONSTANT: SQLITE_NOLFS 22 ! Uses OS features not supported on host
+CONSTANT: SQLITE_AUTH 23 ! Authorization denied
+CONSTANT: SQLITE_FORMAT 24 ! Auxiliary database format error
+CONSTANT: SQLITE_RANGE 25 ! 2nd parameter to sqlite3_bind out of range
+CONSTANT: SQLITE_NOTADB 26 ! File opened that is not a database file
+
+CONSTANT: sqlite-error-messages
+{
+ "Successful result"
+ "SQL error or missing database"
+ "An internal logic error in SQLite"
+ "Access permission denied"
+ "Callback routine requested an abort"
+ "The database file is locked"
+ "A table in the database is locked"
+ "A malloc() failed"
+ "Attempt to write a readonly database"
+ "Operation terminated by sqlite_interrupt()"
+ "Some kind of disk I/O error occurred"
+ "The database disk image is malformed"
+ "(Internal Only) Table or record not found"
+ "Insertion failed because database is full"
+ "Unable to open the database file"
+ "Database lock protocol error"
+ "(Internal Only) Database table is empty"
+ "The database schema changed"
+ "Too much data for one row of a table"
+ "Abort due to contraint violation"
+ "Data type mismatch"
+ "Library used incorrectly"
+ "Uses OS features not supported on host"
+ "Authorization denied"
+ "Auxiliary database format error"
+ "2nd parameter to sqlite3_bind out of range"
+ "File opened that is not a database file"
+}
+
+! Return values from sqlite3_step
+CONSTANT: SQLITE_ROW 100
+CONSTANT: SQLITE_DONE 101
+
+! Return values from the sqlite3_column_type function
+CONSTANT: SQLITE_INTEGER 1
+CONSTANT: SQLITE_FLOAT 2
+CONSTANT: SQLITE_TEXT 3
+CONSTANT: SQLITE_BLOB 4
+CONSTANT: SQLITE_NULL 5
+
+! Values for the 'destructor' parameter of the 'bind' routines.
+CONSTANT: SQLITE_STATIC 0
+CONSTANT: SQLITE_TRANSIENT -1
+
+CONSTANT: SQLITE_OPEN_READONLY HEX: 00000001
+CONSTANT: SQLITE_OPEN_READWRITE HEX: 00000002
+CONSTANT: SQLITE_OPEN_CREATE HEX: 00000004
+CONSTANT: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008
+CONSTANT: SQLITE_OPEN_EXCLUSIVE HEX: 00000010
+CONSTANT: SQLITE_OPEN_MAIN_DB HEX: 00000100
+CONSTANT: SQLITE_OPEN_TEMP_DB HEX: 00000200
+CONSTANT: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400
+CONSTANT: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800
+CONSTANT: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000
+CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000
+CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000
+
+TYPEDEF: void sqlite3
+TYPEDEF: void sqlite3_stmt
+TYPEDEF: longlong sqlite3_int64
+TYPEDEF: ulonglong sqlite3_uint64
+
+FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
+FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
+FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ;
+FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
+FUNCTION: int sqlite3_prepare_v2 ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
+FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
+FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
+FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
+FUNCTION: sqlite3_uint64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
+FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ;
+FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ;
+FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
+FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ;
+! Bind the same function as above, but for unsigned 64bit integers
+: sqlite3-bind-uint64 ( pStmt index in64 -- int )
+ "int" "sqlite" "sqlite3_bind_int64"
+ { "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ;
+FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
+FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
+FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
+FUNCTION: int sqlite3_clear_bindings ( sqlite3_stmt* pStmt ) ;
+FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ;
+FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
+! Bind the same function as above, but for unsigned 64bit integers
+: sqlite3-column-uint64 ( pStmt col -- uint64 )
+ "sqlite3_uint64" "sqlite" "sqlite3_column_int64"
+ { "sqlite3_stmt*" "int" } alien-invoke ;
+FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db2.connections db2.introspection
+db2.sqlite.introspection db2.tester db2.types tools.test ;
+IN: db2.sqlite.introspection.tests
+
+
+: test-sqlite-introspection ( -- )
+ [
+ {
+ T{ table-schema
+ { table "computer" }
+ { columns
+ {
+ T{ column
+ { name "name" }
+ { type VARCHAR }
+ { modifiers "" }
+ }
+ T{ column
+ { name "os" }
+ { type VARCHAR }
+ { modifiers "" }
+ }
+ }
+ }
+ }
+ }
+ ] [
+
+ sqlite-test-db [
+ "computer" query-table-schema
+ ] with-db
+ ] unit-test
+
+ ;
+
+[ test-sqlite-introspection ] test-sqlite
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays db2 db2.introspection db2.sqlite multiline
+sequences ;
+IN: db2.sqlite.introspection
+
+M: sqlite-db-connection query-table-schema*
+ 1array
+<"
+SELECT sql FROM
+ (SELECT * FROM sqlite_master UNION ALL
+ SELECT * FROM sqlite_temp_master)
+WHERE type!='meta' and tbl_name = ?
+ORDER BY tbl_name, type DESC, name
+">
+ sql-bind-query* first ;
--- /dev/null
+! Copyright (C) 2008 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types arrays calendar.format
+combinators db2.sqlite.errors
+io.backend io.encodings.string io.encodings.utf8 kernel math
+namespaces present sequences serialize urls db2.sqlite.ffi ;
+IN: db2.sqlite.lib
+
+: sqlite-check-result ( n -- )
+ {
+ { SQLITE_OK [ ] }
+ { SQLITE_ERROR [ sqlite-statement-error ] }
+ [ throw-sqlite-error ]
+ } case ;
+
+: sqlite-open ( path -- db )
+ "void*" <c-object>
+ [ sqlite3_open sqlite-check-result ] keep *void* ;
+
+: sqlite-close ( db -- )
+ sqlite3_close sqlite-check-result ;
+
+: sqlite-prepare ( db sql -- handle )
+ utf8 encode dup length "void*" <c-object> "void*" <c-object>
+ [ sqlite3_prepare_v2 sqlite-check-result ] 2keep
+ drop *void* ;
+
+: sqlite-bind-parameter-index ( handle name -- index )
+ sqlite3_bind_parameter_index ;
+
+: parameter-index ( handle name text -- handle name text )
+ [ dupd sqlite-bind-parameter-index ] dip ;
+
+: sqlite-bind-text ( handle index text -- )
+ utf8 encode dup length SQLITE_TRANSIENT
+ sqlite3_bind_text sqlite-check-result ;
+
+: sqlite-bind-int ( handle i n -- )
+ sqlite3_bind_int sqlite-check-result ;
+
+: sqlite-bind-int64 ( handle i n -- )
+ sqlite3_bind_int64 sqlite-check-result ;
+
+: sqlite-bind-uint64 ( handle i n -- )
+ sqlite3-bind-uint64 sqlite-check-result ;
+
+: sqlite-bind-boolean ( handle name obj -- )
+ >boolean 1 0 ? sqlite-bind-int ;
+
+: sqlite-bind-double ( handle i x -- )
+ sqlite3_bind_double sqlite-check-result ;
+
+: sqlite-bind-null ( handle i -- )
+ sqlite3_bind_null sqlite-check-result ;
+
+: sqlite-bind-blob ( handle i byte-array -- )
+ dup length SQLITE_TRANSIENT
+ sqlite3_bind_blob sqlite-check-result ;
+
+: sqlite-bind-text-by-name ( handle name text -- )
+ parameter-index sqlite-bind-text ;
+
+: sqlite-bind-int-by-name ( handle name int -- )
+ parameter-index sqlite-bind-int ;
+
+: sqlite-bind-int64-by-name ( handle name int64 -- )
+ parameter-index sqlite-bind-int64 ;
+
+: sqlite-bind-uint64-by-name ( handle name int64 -- )
+ parameter-index sqlite-bind-uint64 ;
+
+: sqlite-bind-boolean-by-name ( handle name obj -- )
+ >boolean 1 0 ? parameter-index sqlite-bind-int ;
+
+: sqlite-bind-double-by-name ( handle name double -- )
+ parameter-index sqlite-bind-double ;
+
+: sqlite-bind-blob-by-name ( handle name blob -- )
+ parameter-index sqlite-bind-blob ;
+
+: sqlite-bind-null-by-name ( handle name obj -- )
+ parameter-index drop sqlite-bind-null ;
+
+: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
+: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
+: sqlite-clear-bindings ( handle -- )
+ sqlite3_clear_bindings sqlite-check-result ;
+: sqlite-#columns ( query -- int ) sqlite3_column_count ;
+: sqlite-column ( handle index -- string ) sqlite3_column_text ;
+: sqlite-column-name ( handle index -- string ) sqlite3_column_name ;
+: sqlite-column-type ( handle index -- string ) sqlite3_column_type ;
+
+: sqlite-column-blob ( handle index -- byte-array/f )
+ [ sqlite3_column_bytes ] 2keep
+ pick zero? [
+ 3drop f
+ ] [
+ sqlite3_column_blob swap memory>byte-array
+ ] if ;
+
+: sqlite-step-has-more-rows? ( prepared -- ? )
+ {
+ { SQLITE_ROW [ t ] }
+ { SQLITE_DONE [ f ] }
+ [ sqlite-check-result f ]
+ } case ;
+
+: sqlite-next ( prepared -- ? )
+ sqlite3_step sqlite-step-has-more-rows? ;
+
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors db2.result-sets db2.sqlite.statements
+db2.statements kernel db2.sqlite.lib destructors
+db2.sqlite.types ;
+IN: db2.sqlite.result-sets
+
+TUPLE: sqlite-result-set < result-set has-more? ;
+
+M: sqlite-result-set dispose
+ f >>handle drop ;
+
+M: sqlite-statement statement>result-set*
+ prepare-statement
+ sqlite-result-set new-result-set dup advance-row ;
+
+M: sqlite-result-set advance-row ( result-set -- )
+ dup handle>> sqlite-next >>has-more? drop ;
+
+M: sqlite-result-set more-rows? ( result-set -- )
+ has-more?>> ;
+
+M: sqlite-result-set #columns ( result-set -- n )
+ handle>> sqlite-#columns ;
+
+M: sqlite-result-set column ( result-set n -- obj )
+ [ handle>> ] [ sqlite-column ] bi* ;
+
+M: sqlite-result-set column-typed ( result-set n type -- obj )
+ [ handle>> ] 2dip sqlite-type ;
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: constructors db2.connections ;
+IN: db2.sqlite
+
+TUPLE: sqlite-db path ;
+CONSTRUCTOR: sqlite-db ( path -- sqlite-db ) ;
+
+TUPLE: sqlite-db-connection < db-connection ;
+
+: <sqlite-db-connection> ( handle -- db-connection )
+ sqlite-db-connection new-db-connection ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors db2.connections db2.sqlite.connections
+db2.sqlite.ffi db2.sqlite.lib db2.statements destructors kernel
+namespaces db2.sqlite ;
+IN: db2.sqlite.statements
+
+TUPLE: sqlite-statement < statement ;
+
+M: sqlite-db-connection <statement> ( string in out -- obj )
+ sqlite-statement new-statement ;
+
+M: sqlite-statement dispose
+ handle>>
+ [ [ sqlite3_reset drop ] [ sqlite-finalize ] bi ] when* ;
+
+M: sqlite-statement prepare-statement* ( statement -- statement )
+ db-connection get handle>> over sql>> sqlite-prepare
+ >>handle ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays calendar.format combinators
+db2.sqlite.ffi db2.sqlite.lib db2.sqlite.statements
+db2.statements db2.types db2.utils fry kernel math present
+sequences serialize urls ;
+IN: db2.sqlite.types
+
+: (bind-sqlite-type) ( handle key value type -- )
+ dup array? [ first ] when
+ {
+ { INTEGER [ sqlite-bind-int-by-name ] }
+ { BIG-INTEGER [ sqlite-bind-int64-by-name ] }
+ { SIGNED-BIG-INTEGER [ sqlite-bind-int64-by-name ] }
+ { UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64-by-name ] }
+ { BOOLEAN [ sqlite-bind-boolean-by-name ] }
+ { TEXT [ sqlite-bind-text-by-name ] }
+ { VARCHAR [ sqlite-bind-text-by-name ] }
+ { DOUBLE [ sqlite-bind-double-by-name ] }
+ { DATE [ timestamp>ymd sqlite-bind-text-by-name ] }
+ { TIME [ timestamp>hms sqlite-bind-text-by-name ] }
+ { DATETIME [ timestamp>ymdhms sqlite-bind-text-by-name ] }
+ { TIMESTAMP [ timestamp>ymdhms sqlite-bind-text-by-name ] }
+ { BLOB [ sqlite-bind-blob-by-name ] }
+ { FACTOR-BLOB [ object>bytes sqlite-bind-blob-by-name ] }
+ { URL [ present sqlite-bind-text-by-name ] }
+ { +db-assigned-id+ [ sqlite-bind-int-by-name ] }
+ { +random-id+ [ sqlite-bind-int64-by-name ] }
+ { NULL [ sqlite-bind-null-by-name ] }
+ [ no-sql-type ]
+ } case ;
+
+: bind-next-sqlite-type ( handle key value type -- )
+ dup array? [ first ] when
+ {
+ { INTEGER [ sqlite-bind-int ] }
+ { BIG-INTEGER [ sqlite-bind-int64 ] }
+ { SIGNED-BIG-INTEGER [ sqlite-bind-int64 ] }
+ { UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64 ] }
+ { BOOLEAN [ sqlite-bind-boolean ] }
+ { TEXT [ sqlite-bind-text ] }
+ { VARCHAR [ sqlite-bind-text ] }
+ { DOUBLE [ sqlite-bind-double ] }
+ { DATE [ timestamp>ymd sqlite-bind-text ] }
+ { TIME [ timestamp>hms sqlite-bind-text ] }
+ { DATETIME [ timestamp>ymdhms sqlite-bind-text ] }
+ { TIMESTAMP [ timestamp>ymdhms sqlite-bind-text ] }
+ { BLOB [ sqlite-bind-blob ] }
+ { FACTOR-BLOB [ object>bytes sqlite-bind-blob ] }
+ { URL [ present sqlite-bind-text ] }
+ { +db-assigned-id+ [ sqlite-bind-int ] }
+ { +random-id+ [ sqlite-bind-int64 ] }
+ { NULL [ drop sqlite-bind-null ] }
+ [ no-sql-type ]
+ } case ;
+
+: bind-sqlite-type ( handle key value type -- )
+ #! null and empty values need to be set by sqlite-bind-null-by-name
+ over [
+ NULL = [ 2drop NULL NULL ] when
+ ] [
+ drop NULL
+ ] if* (bind-sqlite-type) ;
+
+: sqlite-type ( handle index type -- obj )
+ dup array? [ first ] when
+ {
+ { +db-assigned-id+ [ sqlite3_column_int64 ] }
+ { +random-id+ [ sqlite3-column-uint64 ] }
+ { INTEGER [ sqlite3_column_int ] }
+ { BIG-INTEGER [ sqlite3_column_int64 ] }
+ { SIGNED-BIG-INTEGER [ sqlite3_column_int64 ] }
+ { UNSIGNED-BIG-INTEGER [ sqlite3-column-uint64 ] }
+ { BOOLEAN [ sqlite3_column_int 1 = ] }
+ { DOUBLE [ sqlite3_column_double ] }
+ { TEXT [ sqlite3_column_text ] }
+ { VARCHAR [ sqlite3_column_text ] }
+ { DATE [ sqlite3_column_text [ ymd>timestamp ] ?when ] }
+ { TIME [ sqlite3_column_text [ hms>timestamp ] ?when ] }
+ { TIMESTAMP [ sqlite3_column_text [ ymdhms>timestamp ] ?when ] }
+ { DATETIME [ sqlite3_column_text [ ymdhms>timestamp ] ?when ] }
+ { BLOB [ sqlite-column-blob ] }
+ { URL [ sqlite3_column_text [ >url ] ?when ] }
+ { FACTOR-BLOB [ sqlite-column-blob [ bytes>object ] ?when ] }
+ [ no-sql-type ]
+ } case ;
+
+M: sqlite-statement bind-sequence ( statement -- )
+ [ in>> ] [ handle>> ] bi '[
+ [ _ ] 2dip 1+ swap sqlite-bind-text
+ ] each-index ;
+
+M: sqlite-statement bind-typed-sequence ( statement -- )
+ [ in>> ] [ handle>> ] bi '[
+ [ _ ] 2dip 1+ swap first2 swap bind-next-sqlite-type
+ ] each-index ;
+
+ERROR: no-fql-type type ;
+
+: sqlite-type>fql-type ( string -- type )
+ {
+ { "varchar" [ VARCHAR ] }
+ [ no-fql-type ]
+ } case ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test db2.statements kernel db2 db2.tester
+continuations db2.errors accessors db2.types ;
+IN: db2.statements.tests
+
+{ 1 0 } [ [ drop ] result-set-each ] must-infer-as
+{ 1 1 } [ [ ] result-set-map ] must-infer-as
+
+: create-computer-table ( -- )
+ [ "drop table computer;" sql-command ] ignore-errors
+
+ [ "drop table computer;" sql-command ]
+ [ [ sql-table-missing? ] [ table>> "computer" = ] bi and ] must-fail-with
+
+ [ ] [
+ "create table computer(name varchar, os varchar, version integer);"
+ sql-command
+ ] unit-test ;
+
+
+: test-sql-command ( -- )
+ create-computer-table
+
+ [ ] [
+ "insert into computer (name, os) values('rocky', 'mac');"
+ sql-command
+ ] unit-test
+
+ [ { { "rocky" "mac" } } ]
+ [
+ "select name, os from computer;"
+ f f <statement> sql-query
+ ] unit-test
+
+ [ "insert into" sql-command ]
+ [ sql-syntax-error? ] must-fail-with
+
+ [ "selectt" sql-query ]
+ [ sql-syntax-error? ] must-fail-with
+
+ [ ] [
+ "insert into computer (name, os, version) values(?, ?, ?);"
+ { "clubber" "windows" "7" }
+ f <statement>
+ sql-bind-command
+ ] unit-test
+
+ [ { { "windows" } } ] [
+ "select os from computer where name = ?;"
+ { "clubber" } f <statement> sql-bind-query
+ ] unit-test
+
+ [ { { "windows" 7 } } ] [
+ "select os, version from computer where name = ?;"
+ { { VARCHAR "clubber" } }
+ { VARCHAR INTEGER }
+ <statement> sql-bind-typed-query
+ ] unit-test
+
+ [ ] [
+ "insert into computer (name, os, version) values(?, ?, ?);"
+ {
+ { VARCHAR "paulie" }
+ { VARCHAR "netbsd" }
+ { INTEGER 7 }
+ } f <statement>
+ sql-bind-typed-command
+ ] unit-test
+
+ ;
+
+[ test-sql-command ] test-dbs
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors continuations destructors fry kernel
+sequences db2.result-sets db2.connections db2.errors ;
+IN: db2.statements
+
+TUPLE: statement handle sql in out type ;
+
+: new-statement ( sql in out class -- statement )
+ new
+ swap >>out
+ swap >>in
+ swap >>sql ;
+
+HOOK: <statement> db-connection ( sql in out -- statement )
+GENERIC: statement>result-set* ( statement -- result-set )
+GENERIC: execute-statement* ( statement type -- )
+GENERIC: prepare-statement* ( statement -- statement' )
+GENERIC: bind-sequence ( statement -- )
+GENERIC: bind-typed-sequence ( statement -- )
+
+: statement>result-set ( statement -- result-set )
+ [ statement>result-set* ]
+ [ dup sql-error? [ parse-sql-error ] when rethrow ] recover ;
+
+M: object execute-statement* ( statement type -- )
+ drop statement>result-set dispose ;
+
+: execute-one-statement ( statement -- )
+ dup type>> execute-statement* ;
+
+: execute-statement ( statement -- )
+ dup sequence?
+ [ [ execute-one-statement ] each ]
+ [ execute-one-statement ] if ;
+
+: prepare-statement ( statement -- statement )
+ dup handle>> [ prepare-statement* ] unless ;
+
+: result-set-each ( statement quot: ( statement -- ) -- )
+ over more-rows?
+ [ [ call ] 2keep over advance-row result-set-each ]
+ [ 2drop ] if ; inline recursive
+
+: result-set-map ( statement quot -- sequence )
+ accumulator [ result-set-each ] dip { } like ; inline
+
+: statement>result-sequence ( statement -- sequence )
+ statement>result-set [ [ sql-row ] result-set-map ] with-disposal ;
+
+: statement>typed-result-sequence ( statement -- sequence )
+ statement>result-set
+ [ [ sql-row-typed ] result-set-map ] with-disposal ;
--- /dev/null
+Slava Pestov
+Doug Coleman
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test db2.tester ;
+IN: db2.tester.tests
+
+! [ ] [ sqlite-test-db db-tester ] unit-test
+! [ ] [ sqlite-test-db db-tester2 ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: concurrency.combinators db2.connections
+db2.pools db2.sqlite db2.types fry io.files.temp kernel math
+namespaces random threads tools.test combinators ;
+IN: db2.tester
+USE: multiline
+
+: sqlite-test-db ( -- sqlite-db )
+ "tuples-test.db" temp-file <sqlite-db> ;
+
+! These words leak resources, but are useful for interactivel testing
+: set-sqlite-db ( -- )
+ sqlite-db db-open db-connection set ;
+
+: test-sqlite ( quot -- )
+ '[
+ [ ] [ sqlite-test-db _ with-db ] unit-test
+ ] call ; inline
+
+: test-dbs ( quot -- )
+ {
+ [ test-sqlite ]
+ } cleave ;
+
+/*
+: postgresql-test-db ( -- postgresql-db )
+ <postgresql-db>
+ "localhost" >>host
+ "postgres" >>username
+ "thepasswordistrust" >>password
+ "factor-test" >>database ;
+
+: set-postgresql-db ( -- )
+ postgresql-db db-open db-connection set ;
+
+: test-postgresql ( quot -- )
+ '[
+ os windows? cpu x86.64? and [
+ [ ] [ postgresql-test-db _ with-db ] unit-test
+ ] unless
+ ] call ; inline
+
+TUPLE: test-1 id a b c ;
+
+test-1 "TEST1" {
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "a" "A" { VARCHAR 256 } +not-null+ }
+ { "b" "B" { VARCHAR 256 } +not-null+ }
+ { "c" "C" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+TUPLE: test-2 id x y z ;
+
+test-2 "TEST2" {
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "x" "X" { VARCHAR 256 } +not-null+ }
+ { "y" "Y" { VARCHAR 256 } +not-null+ }
+ { "z" "Z" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+: db-tester ( test-db -- )
+ [
+ [
+ test-1 ensure-table
+ test-2 ensure-table
+ ] with-db
+ ] [
+ 10 [
+ drop
+ 10 [
+ dup [
+ f 100 random 100 random 100 random test-1 boa
+ insert-tuple yield
+ ] with-db
+ ] times
+ ] with parallel-each
+ ] bi ;
+
+: db-tester2 ( test-db -- )
+ [
+ [
+ test-1 ensure-table
+ test-2 ensure-table
+ ] with-db
+ ] [
+ <db-pool> [
+ 10 [
+ 10 [
+ f 100 random 100 random 100 random test-1 boa
+ insert-tuple yield
+ ] times
+ ] parallel-each
+ ] with-pooled-db
+ ] bi ;
+*/
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: continuations db2 db2.connections namespaces ;
+IN: db2.transactions
+
+SYMBOL: in-transaction
+
+HOOK: begin-transaction db-connection ( -- )
+
+HOOK: commit-transaction db-connection ( -- )
+
+HOOK: rollback-transaction db-connection ( -- )
+
+M: db-connection begin-transaction ( -- ) "BEGIN" sql-command ;
+
+M: db-connection commit-transaction ( -- ) "COMMIT" sql-command ;
+
+M: db-connection rollback-transaction ( -- ) "ROLLBACK" sql-command ;
+
+: in-transaction? ( -- ? ) in-transaction get ;
+
+: with-transaction ( quot -- )
+ t in-transaction [
+ begin-transaction
+ [ ] [ rollback-transaction ] cleanup commit-transaction
+ ] with-variable ; inline
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ;
+IN: db2.types
+
+SINGLETONS: +db-assigned-id+ +user-assigned-id+ +random-id+ ;
+UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
+
+SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
++foreign-id+ +has-many+ +on-update+ +on-delete+ +restrict+ +cascade+
++set-null+ +set-default+ ;
+
+SINGLETONS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
+DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
+FACTOR-BLOB NULL URL ;
+
+ERROR: no-sql-type type ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel math math.parser strings sequences
+words ;
+IN: db2.utils
+
+: ?when ( object quot -- object' ) dupd when ; inline
+: ?1array ( obj -- array ) dup string? [ 1array ] when ; inline
+: ??1array ( obj -- array/f ) [ ?1array ] ?when ; inline
+
+: ?first ( sequence -- object/f ) 0 ?nth ;
+: ?second ( sequence -- object/f ) 1 ?nth ;
+
+: ?first2 ( sequence -- object1/f object2/f )
+ [ ?first ] [ ?second ] bi ;
+
+: assoc-with ( object sequence quot -- obj curry )
+ swapd [ [ -rot ] dip call ] 2curry ; inline
+
+: ?number>string ( n/string -- string )
+ dup number? [ number>string ] when ;
+
+ERROR: no-accessor name ;
+
+: lookup-accessor ( string -- accessor )
+ dup ">>" append "accessors" lookup
+ [ nip ] [ no-accessor ] if* ;
+
+ERROR: string-expected object ;
+
+: ensure-string ( object -- string )
+ dup string? [ string-expected ] unless ;
-
-USING: kernel fry sequences
- vocabs.loader help.vocabs
- ui ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.scrollers
- ui.tools.listener
- accessors ;
-
+USING: kernel fry sequences vocabs.loader help.vocabs ui
+ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.borders
+ui.gadgets.scrollers ui.tools.listener accessors ;
IN: demos
: demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ;
: <run-vocab-button> ( vocab-name -- button )
- dup '[ drop [ _ run ] call-listener ] <border-button> ;
+ dup '[ drop [ _ run ] \ run call-listener ] <border-button> ;
: <demo-runner> ( -- gadget )
- <pile> 1 >>fill demo-vocabs [ <run-vocab-button> add-gadget ] each ;
-
-: demos ( -- ) [ <demo-runner> <scroller> "Demos" open-window ] with-ui ;
+ <pile> 1 >>fill { 2 2 } >>gap demo-vocabs [ <run-vocab-button> add-gadget ] each ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: demos ( -- ) [ <demo-runner> { 2 2 } <border> <scroller> "Demos" open-window ] with-ui ;
MAIN: demos
\ No newline at end of file
-USING: help.syntax help.markup ;\r
+USING: help.syntax help.markup words ;\r
IN: descriptive\r
\r
HELP: DESCRIPTIVE:\r
{ $syntax "DESCRIPTIVE: word ( inputs -- outputs ) definition ;" }\r
-{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ;\r
+{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ;\r
\r
HELP: DESCRIPTIVE::\r
{ $syntax "DESCRIPTIVE:: word ( inputs -- outputs ) definition ;" }\r
-{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ;\r
+{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ;\r
\r
-HELP: descriptive\r
-{ $class-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ;\r
+HELP: descriptive-error\r
+{ $error-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ;\r
+\r
+HELP: make-descriptive\r
+{ $values { "word" word } }\r
+{ $description "Makes the word wrap errors in " { $link descriptive-error } " instances." } ;\r
\r
ARTICLE: "descriptive" "Descriptive errors"\r
-"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in a special descriptor declaring that an error was thrown from inside that word, and including the arguments given to that word. The error is of the following class:"\r
-{ $subsection descriptive }\r
+"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in an instance of a class:"\r
+{ $subsection descriptive-error }\r
+"The wrapper contains the word itself, the input parameters, as well as the original error."\r
+$nl\r
+"To annotate an existing word with descriptive error checking:"\r
+{ $subsection make-descriptive }\r
"To define words which throw descriptive errors, use the following words:"\r
{ $subsection POSTPONE: DESCRIPTIVE: }\r
{ $subsection POSTPONE: DESCRIPTIVE:: } ;\r
-USING: words kernel sequences locals locals.parser
+! Copyright (c) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: words kernel sequences locals locals.parser fry
locals.definitions accessors parser namespaces continuations
-summary definitions generalizations arrays ;
+summary definitions generalizations arrays prettyprint debugger io
+effects tools.annotations ;
IN: descriptive
ERROR: descriptive-error args underlying word ;
-M: descriptive-error summary
- word>> "The " swap name>> " word encountered an error."
- 3append ;
+M: descriptive-error error.
+ "The word " write dup word>> pprint " encountered an error." print
+ "Arguments:" print
+ dup args>> stack.
+ "Error:" print
+ underlying>> error. ;
<PRIVATE
PRIVATE>
+: make-descriptive ( word -- )
+ dup [ ] [ def>> ] [ stack-effect ] tri [descriptive]
+ '[ drop _ ] annotate-methods ;
+
: define-descriptive ( word def effect -- )
[ drop "descriptive-definition" set-word-prop ]
[ [ [ dup ] 2dip [descriptive] ] keep define-declared ]
--- /dev/null
+extensions
USING: assocs html.parser kernel math sequences strings ascii
arrays generalizations shuffle unicode.case namespaces make
splitting http accessors io combinators http.client urls
-urls.encoding fry prettyprint ;
+urls.encoding fry prettyprint sets ;
IN: html.parser.analyzer
TUPLE: link attributes clickable ;
[ [
[ name>> "a" = ]
[ attributes>> "href" swap key? ] bi and ] filter
- ] map sift [ [ attributes>> "href" swap at ] map ] map concat ;
+ ] map sift
+ [ [ attributes>> "href" swap at ] map ] map concat
+ [ >url ] map ;
+
+: find-frame-links ( vector -- vector' )
+ [ name>> "frame" = ] find-between-all
+ [ [ attributes>> "src" swap at ] map sift ] map concat sift
+ [ >url ] map ;
+
+: find-all-links ( vector -- vector' )
+ [ find-hrefs ] [ find-frame-links ] bi append prune ;
: find-forms ( vector -- vector' )
"form" over find-opening-tags-by-name
}
] [ "<a href = \"http://factorcode.org/\" foo = bar baz='quux'a=pirsqd >" parse-html ] unit-test
+[
+V{
+ T{ tag f "a"
+ H{
+ { "a" "pirsqd" }
+ { "foo" "bar" }
+ { "href" "http://factorcode.org/" }
+ { "baz" "quux" }
+ { "nofollow" "nofollow" }
+ } f f }
+}
+] [ "<a href = \"http://factorcode.org/\" nofollow foo = bar baz='quux'a=pirsqd >" parse-html ] unit-test
+
[
V{
T{ tag f "html" H{ } f f }
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays hashtables html.parser.state
-html.parser.utils kernel make namespaces sequences
+USING: accessors arrays hashtables sequence-parser
+html.parser.utils kernel namespaces sequences
unicode.case unicode.categories combinators.short-circuit
-quoting ;
+quoting fry ;
IN: html.parser
-
TUPLE: tag name attributes text closing? ;
SINGLETON: text
SINGLETON: dtd
SINGLETON: comment
+
+<PRIVATE
+
SYMBOL: tagstack
: push-tag ( tag -- )
: closing-tag? ( string -- ? )
[ f ]
- [ [ first ] [ peek ] bi [ CHAR: / = ] bi@ or ] if-empty ;
+ [ { [ first CHAR: / = ] [ peek CHAR: / = ] } 1|| ] if-empty ;
: <tag> ( name attributes closing? -- tag )
tag new
: make-tag ( string attribs -- tag )
[ [ closing-tag? ] keep "/" trim1 ] dip rot <tag> ;
-: new-tag ( string type -- tag )
+: new-tag ( text name -- tag )
tag new
swap >>name
swap >>text ; inline
-: make-text-tag ( string -- tag ) text new-tag ; inline
+: (read-quote) ( sequence-parser ch -- string )
+ '[ [ current _ = ] take-until ] [ advance drop ] bi ;
-: make-comment-tag ( string -- tag ) comment new-tag ; inline
+: read-single-quote ( sequence-parser -- string )
+ CHAR: ' (read-quote) ;
-: make-dtd-tag ( string -- tag ) dtd new-tag ; inline
+: read-double-quote ( sequence-parser -- string )
+ CHAR: " (read-quote) ;
-: read-single-quote ( state-parser -- string )
- [ [ CHAR: ' = ] take-until ] [ next drop ] bi ;
-
-: read-double-quote ( state-parser -- string )
- [ [ CHAR: " = ] take-until ] [ next drop ] bi ;
-
-: read-quote ( state-parser -- string )
+: read-quote ( sequence-parser -- string )
dup get+increment CHAR: ' =
[ read-single-quote ] [ read-double-quote ] if ;
-: read-key ( state-parser -- string )
+: read-key ( sequence-parser -- string )
skip-whitespace
- [ { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
+ [ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
-: read-= ( state-parser -- )
- skip-whitespace
- [ [ CHAR: = = ] take-until drop ] [ next drop ] bi ;
+: read-token ( sequence-parser -- string )
+ [ current blank? ] take-until ;
-: read-token ( state-parser -- string )
- [ blank? ] take-until ;
-
-: read-value ( state-parser -- string )
+: read-value ( sequence-parser -- string )
skip-whitespace
- dup get-char quote? [ read-quote ] [ read-token ] if
+ dup current quote? [ read-quote ] [ read-token ] if
[ blank? ] trim ;
-: read-comment ( state-parser -- )
- "-->" take-until-sequence make-comment-tag push-tag ;
+: read-comment ( sequence-parser -- )
+ "-->" take-until-sequence comment new-tag push-tag ;
-: read-dtd ( state-parser -- )
- ">" take-until-sequence make-dtd-tag push-tag ;
+: read-dtd ( sequence-parser -- )
+ ">" take-until-sequence dtd new-tag push-tag ;
-: read-bang ( state-parser -- )
- next dup { [ get-char CHAR: - = ] [ get-next CHAR: - = ] } 1&& [
- next next
- read-comment
- ] [
- read-dtd
- ] if ;
+: read-bang ( sequence-parser -- )
+ advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&&
+ [ advance advance read-comment ] [ read-dtd ] if ;
-: read-tag ( state-parser -- string )
- [ [ "><" member? ] take-until ]
- [ dup get-char CHAR: < = [ next ] unless drop ] bi ;
+: read-tag ( sequence-parser -- string )
+ [ [ current "><" member? ] take-until ]
+ [ dup current CHAR: < = [ advance ] unless drop ] bi ;
-: read-until-< ( state-parser -- string )
- [ CHAR: < = ] take-until ;
+: read-until-< ( sequence-parser -- string )
+ [ current CHAR: < = ] take-until ;
-: parse-text ( state-parser -- )
- read-until-< [ make-text-tag push-tag ] unless-empty ;
+: parse-text ( sequence-parser -- )
+ read-until-< [ text new-tag push-tag ] unless-empty ;
-: (parse-attributes) ( state-parser -- )
+: parse-key/value ( sequence-parser -- key value )
+ [ read-key >lower ]
+ [ skip-whitespace "=" take-sequence ]
+ [ swap [ read-value ] [ drop dup ] if ] tri ;
+
+: (parse-attributes) ( sequence-parser -- )
skip-whitespace
- dup state-parse-end? [
+ dup sequence-parse-end? [
drop
] [
- [
- [ read-key >lower ] [ read-= ] [ read-value ] tri
- 2array ,
- ] keep (parse-attributes)
+ [ parse-key/value swap set ] [ (parse-attributes) ] bi
] if ;
-: parse-attributes ( state-parser -- hashtable )
- [ (parse-attributes) ] { } make >hashtable ;
+: parse-attributes ( sequence-parser -- hashtable )
+ [ (parse-attributes) ] H{ } make-assoc ;
: (parse-tag) ( string -- string' hashtable )
[
[ read-token >lower ] [ parse-attributes ] bi
- ] state-parse ;
+ ] parse-sequence ;
-: read-< ( state-parser -- string/f )
- next dup get-char [
+: read-< ( sequence-parser -- string/f )
+ advance dup current [
CHAR: ! = [ read-bang f ] [ read-tag ] if
] [
drop f
] if* ;
-: parse-tag ( state-parser -- )
+: parse-tag ( sequence-parser -- )
read-< [ (parse-tag) make-tag push-tag ] unless-empty ;
-: (parse-html) ( state-parser -- )
- dup get-next [
+: (parse-html) ( sequence-parser -- )
+ dup peek-next [
[ parse-text ] [ parse-tag ] [ (parse-html) ] tri
] [ drop ] if ;
: tag-parse ( quot -- vector )
- V{ } clone tagstack [ state-parse ] with-variable ; inline
+ V{ } clone tagstack [ parse-sequence ] with-variable ; inline
+
+PRIVATE>
: parse-html ( string -- vector )
[ (parse-html) tagstack get ] tag-parse ;
+++ /dev/null
-USING: tools.test html.parser.state ascii kernel accessors ;
-IN: html.parser.state.tests
-
-[ "hello" ]
-[ "hello" [ take-rest ] state-parse ] unit-test
-
-[ "hi" " how are you?" ]
-[
- "hi how are you?"
- [ [ [ blank? ] take-until ] [ take-rest ] bi ] state-parse
-] unit-test
-
-[ "foo" ";bar" ]
-[
- "foo;bar" [
- [ CHAR: ; take-until-object ] [ take-rest ] bi
- ] state-parse
-] unit-test
-
-[ "foo " " bar" ]
-[
- "foo and bar" [
- [ "and" take-until-sequence ] [ take-rest ] bi
- ] state-parse
-] unit-test
-
-[ 6 ]
-[
- " foo " [ skip-whitespace n>> ] state-parse
-] unit-test
-
-[ { 1 2 } ]
-[ { 1 2 3 } <state-parser> [ 3 = ] take-until ] unit-test
-
-[ { 1 2 } ]
-[ { 1 2 3 4 } <state-parser> { 3 4 } take-until-sequence ] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces math kernel sequences accessors fry circular
-unicode.case unicode.categories locals ;
-
-IN: html.parser.state
-
-TUPLE: state-parser sequence n ;
-
-: <state-parser> ( sequence -- state-parser )
- state-parser new
- swap >>sequence
- 0 >>n ;
-
-: (get-char) ( n state -- char/f )
- sequence>> ?nth ; inline
-
-: get-char ( state -- char/f )
- [ n>> ] keep (get-char) ; inline
-
-: get-next ( state -- char/f )
- [ n>> 1 + ] keep (get-char) ; inline
-
-: next ( state -- state )
- [ 1 + ] change-n ; inline
-
-: get+increment ( state -- char/f )
- [ get-char ] [ next drop ] bi ; inline
-
-: state-parse ( sequence quot -- )
- [ <state-parser> ] dip call ; inline
-
-:: skip-until ( state quot: ( obj -- ? ) -- )
- state get-char [
- quot call [ state next quot skip-until ] unless
- ] when* ; inline recursive
-
-: state-parse-end? ( state -- ? ) get-next not ;
-
-: take-until ( state quot: ( obj -- ? ) -- sequence/f )
- over state-parse-end? [
- 2drop f
- ] [
- [ drop n>> ]
- [ skip-until ]
- [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
- ] if ; inline
-
-:: take-until-sequence ( state-parser sequence -- sequence' )
- sequence length <growing-circular> :> growing
- state-parser
- [
- growing push-growing-circular
- sequence growing sequence=
- ] take-until :> found
- found dup length
- growing length 1- - head
- state-parser next drop ;
-
-: skip-whitespace ( state -- state )
- [ [ blank? not ] take-until drop ] keep ;
-
-: take-rest ( state -- sequence )
- [ drop f ] take-until ; inline
-
-: take-until-object ( state obj -- sequence )
- '[ _ = ] take-until ;
! See http://factorcode.org/license.txt for BSD license.
USING: assocs circular combinators continuations hashtables
hashtables.private io kernel math namespaces prettyprint
-quotations sequences splitting html.parser.state strings
-combinators.short-circuit quoting ;
+quotations sequences splitting strings quoting
+combinators.short-circuit ;
IN: html.parser.utils
: trim1 ( seq ch -- newseq )
HELP: mp3>id3
{ $values
{ "path" "a path string" }
- { "id3v2-info/f" "a tuple storing ID3v2 metadata or f" } }
+ { "id3/f" "a tuple storing ID3v2 metadata or f" } }
{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Words to access the ID3v1 information are here:"
{ $list
{ $link title }
HELP: album
{ $values
- { "id3" id3v2-info }
- { "album/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the album, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: artist
{ $values
- { "id3" id3v2-info }
- { "artist/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the artist, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: comment
{ $values
- { "id3" id3v2-info }
- { "comment/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the comment, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: genre
{ $values
- { "id3" id3v2-info }
- { "genre/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the genre, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: title
{ $values
- { "id3" id3v2-info }
- { "title/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the title, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: year
{ $values
- { "id3" id3v2-info }
- { "year/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the year, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: find-id3-frame
{ $values
- { "id3" id3v2-info } { "name" string }
+ { "id3" id3 } { "name" string }
{ "obj/f" "object or f" }
}
{ $description "Returns the " { $slot "data" } " slot of the ID3 frame with the given name, or " { $link f } "." } ;
! Copyright (C) 2009 Tim Wawrzynczak
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test id3 combinators ;
+USING: tools.test id3 combinators grouping id3.private
+sequences math ;
IN: id3.tests
: id3-params ( id3 -- title artist album year comment genre )
"Big Band"
] [ "vocab:id3/tests/blah3.mp3" mp3>id3 id3-params ] unit-test
+
+[ t ]
+[ 10000 [ synchsafe>seq seq>synchsafe ] map [ < ] monotonic? ] unit-test
io.encodings.string io.encodings.utf16 assocs math.parser
combinators.short-circuit fry namespaces combinators.smart
splitting io.encodings.ascii arrays io.files.info unicode.case
-io.directories.search ;
+io.directories.search literals math.functions ;
IN: id3
<PRIVATE
"Primus" "Porn Groove" "Satire" "Slow Jam" "Club" "Tango"
"Samba" "Folklore" "Ballad" "Power Ballad" "Rhythmic Soul"
"Freestyle" "Duet" "Punk Rock" "Drum Solo" "A capella"
- "Euro-House" "Dance Hall"
+ "Euro-House" "Dance Hall" "Goa" "Drum & Bass" "Club-House"
+ "Hardcore" "Terror" "Indie" "BritPop" "Negerpunk"
+ "Polsk Punk" "Beat" "Christian Gangsta Rap" "Heavy Metal"
+ "Black Metal" "Crossover" "Contemporary Christian"
+ "Christian Rock"
}
TUPLE: header version flags size ;
-TUPLE: frame frame-id flags size data ;
+TUPLE: frame tag flags size data ;
-TUPLE: id3v2-info header frames ;
+TUPLE: id3 header frames
+title artist album year comment genre
+speed genre-name start-time end-time ;
-TUPLE: id3v1-info title artist album year comment genre ;
-
-: <id3v1-info> ( -- object ) id3v1-info new ; inline
-
-: <id3v2-info> ( header frames -- object )
- [ [ frame-id>> ] keep ] H{ } map>assoc id3v2-info boa ;
+: <id3> ( -- id3 )
+ id3 new
+ H{ } clone >>frames ; inline
: <header> ( -- object ) header new ; inline
: <frame> ( -- object ) frame new ; inline
-: id3v2? ( mmap -- ? ) "ID3" head? ; inline
+: id3v2? ( seq -- ? ) "ID3" head? ; inline
-: id3v1? ( mmap -- ? )
- { [ length 128 >= ] [ 128 tail-slice* "TAG" head? ] } 1&& ; inline
+CONSTANT: id3v1-length 128
+CONSTANT: id3v1-offset 128
+CONSTANT: id3v1+-length 227
+CONSTANT: id3v1+-offset $[ 128 227 + ]
+
+: id3v1? ( seq -- ? )
+ {
+ [ length id3v1-offset >= ]
+ [ id3v1-length tail-slice* "TAG" head? ]
+ } 1&& ;
-: id3v1-frame ( string key -- frame )
- <frame>
- swap >>frame-id
- swap >>data ; inline
+: id3v1+? ( seq -- ? )
+ {
+ [ length id3v1+-offset >= ]
+ [ id3v1+-length tail-slice* "TAG+" head? ]
+ } 1&& ;
+
+: pair>frame ( string key -- frame/f )
+ over [
+ <frame>
+ swap >>tag
+ swap >>data
+ ] [
+ 2drop f
+ ] if ;
-: id3v1>id3v2 ( id3v1 -- id3v2 )
+: id3v1>frames ( id3v1 -- seq )
[
{
- [ title>> "TIT2" id3v1-frame ]
- [ artist>> "TPE1" id3v1-frame ]
- [ album>> "TALB" id3v1-frame ]
- [ year>> "TYER" id3v1-frame ]
- [ comment>> "COMM" id3v1-frame ]
- [ genre>> "TCON" id3v1-frame ]
+ [ title>> "TIT2" pair>frame ]
+ [ artist>> "TPE1" pair>frame ]
+ [ album>> "TALB" pair>frame ]
+ [ year>> "TYER" pair>frame ]
+ [ comment>> "COMM" pair>frame ]
+ [ genre>> "TCON" pair>frame ]
} cleave
- ] output>array f swap <id3v2-info> ; inline
+ ] output>array sift ;
-: >28bitword ( seq -- int )
- 0 [ [ 7 shift ] dip bitor ] reduce ; inline
+: seq>synchsafe ( seq -- n )
+ 0 [ [ 7 shift ] dip bitor ] reduce ;
+
+: synchsafe>seq ( n -- seq )
+ dup 1+ log2 1+ 7 / ceiling
+ [ [ -7 shift ] keep HEX: 7f bitand ] replicate nip reverse ;
: filter-text-data ( data -- filtered )
- [ printable? ] filter ; inline
+ [ printable? ] filter ;
-: valid-frame-id? ( id -- ? )
- [ { [ digit? ] [ LETTER? ] } 1|| ] all? ; inline
+: valid-tag? ( id -- ? )
+ [ { [ digit? ] [ LETTER? ] } 1|| ] all? ;
-: read-frame-data ( frame mmap -- frame data )
- [ 10 over size>> 10 + ] dip <slice> filter-text-data ; inline
+: read-frame-data ( frame seq -- frame data )
+ [ 10 over size>> 10 + ] dip <slice> filter-text-data ;
: decode-text ( string -- string' )
dup 2 short head
{ { HEX: ff HEX: fe } { HEX: fe HEX: ff } } member?
- utf16 ascii ? decode ; inline
+ utf16 ascii ? decode ;
-: (read-frame) ( mmap -- frame )
+: (read-frame) ( seq -- frame )
[ <frame> ] dip
{
- [ 4 head-slice decode-text >>frame-id ]
- [ [ 4 8 ] dip subseq >28bitword >>size ]
+ [ 4 head-slice decode-text >>tag ]
+ [ [ 4 8 ] dip subseq seq>synchsafe >>size ]
[ [ 8 10 ] dip subseq >byte-array >>flags ]
[ read-frame-data decode-text >>data ]
- } cleave ; inline
+ } cleave ;
+
+: read-frame ( seq -- frame/f )
+ dup 4 head-slice valid-tag?
+ [ (read-frame) ] [ drop f ] if ;
-: read-frame ( mmap -- frame/f )
- dup 4 head-slice valid-frame-id?
- [ (read-frame) ] [ drop f ] if ; inline
+: remove-frame ( seq frame -- seq )
+ size>> 10 + tail-slice ;
-: remove-frame ( mmap frame -- mmap )
- size>> 10 + tail-slice ; inline
+: frames>assoc ( seq -- assoc )
+ [ [ tag>> ] keep ] H{ } map>assoc ;
-: read-frames ( mmap -- frames )
- [ dup read-frame dup ]
- [ [ remove-frame ] keep ]
- produce 2nip ; inline
+: read-frames ( seq -- assoc )
+ [ dup read-frame dup ] [ [ remove-frame ] keep ] produce 2nip ;
-: read-v2-header ( seq -- id3header )
+: read-v2-header ( seq -- header )
[ <header> ] dip
{
[ [ 3 5 ] dip <slice> >array >>version ]
[ [ 5 ] dip nth >>flags ]
- [ [ 6 10 ] dip <slice> >28bitword >>size ]
- } cleave ; inline
+ [ [ 6 10 ] dip <slice> seq>synchsafe >>size ]
+ } cleave ;
-: read-v2-tag-data ( seq -- id3v2-info )
+: merge-frames ( id3 assoc -- id3 )
+ [ dup frames>> ] dip update ;
+
+: merge-id3v1 ( id3 -- id3 )
+ dup id3v1>frames frames>assoc merge-frames ;
+
+: read-v2-tags ( id3 seq -- id3 )
10 cut-slice
- [ read-v2-header ]
- [ read-frames ] bi* <id3v2-info> ; inline
+ [ read-v2-header >>header ]
+ [ read-frames frames>assoc merge-frames ] bi* ;
-: skip-to-v1-data ( seq -- seq ) 125 tail-slice* ; inline
-
-: (read-v1-tag-data) ( seq -- mp3-file )
- [ <id3v1-info> ] dip
+: extract-v1-tags ( id3 seq -- id3 )
{
[ 30 head-slice decode-text filter-text-data >>title ]
[ [ 30 60 ] dip subseq decode-text filter-text-data >>artist ]
[ [ 90 94 ] dip subseq decode-text filter-text-data >>year ]
[ [ 94 124 ] dip subseq decode-text filter-text-data >>comment ]
[ [ 124 ] dip nth number>string >>genre ]
- } cleave ; inline
+ } cleave ;
-: read-v1-tag-data ( seq -- mp3-file )
- skip-to-v1-data (read-v1-tag-data) ; inline
+: read-v1-tags ( id3 seq -- id3 )
+ id3v1-offset tail-slice* 3 tail-slice
+ extract-v1-tags ;
+
+: extract-v1+-tags ( id3 seq -- id3 )
+ {
+ [ 60 head-slice decode-text filter-text-data [ append ] change-title ]
+ [
+ [ 60 120 ] dip subseq decode-text filter-text-data
+ [ append ] change-artist
+ ]
+ [
+ [ 120 180 ] dip subseq decode-text filter-text-data
+ [ append ] change-album
+ ]
+ [ [ 180 ] dip nth >>speed ]
+ [ [ 181 211 ] dip subseq decode-text >>genre-name ]
+ [ [ 211 217 ] dip subseq decode-text >>start-time ]
+ [ [ 217 223 ] dip subseq decode-text >>end-time ]
+ } cleave ;
+
+: read-v1+-tags ( id3 seq -- id3 )
+ id3v1+-offset tail-slice* 4 tail-slice
+ extract-v1+-tags ;
: parse-genre ( string -- n/f )
dup "(" ?head-slice drop ")" ?tail-slice drop
genres ?nth swap or
] [
drop
- ] if ; inline
+ ] if ;
-: (mp3>id3) ( path -- id3v2-info/f )
+: (mp3>id3) ( path -- id3v2/f )
[
+ [ <id3> ] dip
{
- { [ dup id3v2? ] [ read-v2-tag-data ] }
- { [ dup id3v1? ] [ read-v1-tag-data id3v1>id3v2 ] }
- [ drop f ]
- } cond
+ [ dup id3v1? [ read-v1-tags merge-id3v1 ] [ drop ] if ]
+ [ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ]
+ [ dup id3v2? [ read-v2-tags ] [ drop ] if ]
+ } cleave
] with-mapped-uchar-file ;
-: (find-id3-frame) ( id3 name quot: ( obj -- obj' ) -- obj' )
- [ swap frames>> at* ] dip
- [ data>> ] prepose [ drop f ] if ; inline
-
PRIVATE>
-: mp3>id3 ( path -- id3v2-info/f )
- dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; inline
+: mp3>id3 ( path -- id3/f )
+ dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ;
: find-id3-frame ( id3 name -- obj/f )
- [ ] (find-id3-frame) ; inline
+ swap frames>> at* [ data>> ] when ;
-: title ( id3 -- title/f ) "TIT2" find-id3-frame ; inline
+: title ( id3 -- string/f ) "TIT2" find-id3-frame ;
-: artist ( id3 -- artist/f ) "TPE1" find-id3-frame ; inline
+: artist ( id3 -- string/f ) "TPE1" find-id3-frame ;
-: album ( id3 -- album/f ) "TALB" find-id3-frame ; inline
+: album ( id3 -- string/f ) "TALB" find-id3-frame ;
-: year ( id3 -- year/f ) "TYER" find-id3-frame ; inline
+: year ( id3 -- string/f ) "TYER" find-id3-frame ;
-: comment ( id3 -- comment/f ) "COMM" find-id3-frame ; inline
+: comment ( id3 -- string/f ) "COMM" find-id3-frame ;
-: genre ( id3 -- genre/f )
- "TCON" [ parse-genre ] (find-id3-frame) ; inline
+: genre ( id3 -- string/f )
+ "TCON" find-id3-frame parse-genre ;
: find-mp3s ( path -- seq )
- [ >lower ".mp3" tail? ] find-all-files ; inline
+ [ >lower ".mp3" tail? ] find-all-files ;
: mp3-paths>id3s ( seq -- seq' )
- [ dup mp3>id3 ] { } map>assoc ; inline
+ [ dup mp3>id3 ] { } map>assoc ;
: parse-mp3-directory ( path -- seq )
find-mp3s mp3-paths>id3s ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Doug Coleman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors grouping sequences combinators
+math specialized-arrays.direct.uint byte-arrays fry
+specialized-arrays.direct.ushort specialized-arrays.uint
+specialized-arrays.ushort specialized-arrays.float images ;
+IN: images.normalization
+
+<PRIVATE
+
+: add-dummy-alpha ( seq -- seq' )
+ 3 <groups> [ 255 suffix ] map concat ;
+
+: normalize-floats ( byte-array -- byte-array )
+ byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
+
+GENERIC: normalize-component-order* ( image component-order -- image )
+
+: normalize-component-order ( image -- image )
+ dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
+
+M: RGBA normalize-component-order* drop ;
+
+M: R32G32B32A32 normalize-component-order*
+ drop normalize-floats ;
+
+M: R32G32B32 normalize-component-order*
+ drop normalize-floats add-dummy-alpha ;
+
+: RGB16>8 ( bitmap -- bitmap' )
+ byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
+
+M: R16G16B16A16 normalize-component-order*
+ drop RGB16>8 ;
+
+M: R16G16B16 normalize-component-order*
+ drop RGB16>8 add-dummy-alpha ;
+
+: BGR>RGB ( bitmap -- pixels )
+ 3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
+
+: BGRA>RGBA ( bitmap -- pixels )
+ 4 <sliced-groups>
+ [ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
+
+M: BGRA normalize-component-order*
+ drop BGRA>RGBA ;
+
+M: RGB normalize-component-order*
+ drop add-dummy-alpha ;
+
+M: BGR normalize-component-order*
+ drop BGR>RGB add-dummy-alpha ;
+
+: ARGB>RGBA ( bitmap -- bitmap' )
+ 4 <groups> [ unclip suffix ] map B{ } join ; inline
+
+M: ARGB normalize-component-order*
+ drop ARGB>RGBA ;
+
+M: ABGR normalize-component-order*
+ drop ARGB>RGBA BGRA>RGBA ;
+
+: fix-XBGR ( bitmap -- bitmap' )
+ dup 4 <sliced-groups> [ [ 255 0 ] dip set-nth ] each ;
+
+M: XBGR normalize-component-order*
+ drop fix-XBGR ABGR normalize-component-order* ;
+
+: fix-BGRX ( bitmap -- bitmap' )
+ dup 4 <sliced-groups> [ [ 255 3 ] dip set-nth ] each ;
+
+M: BGRX normalize-component-order*
+ drop fix-BGRX BGRA normalize-component-order* ;
+
+: normalize-scan-line-order ( image -- image )
+ dup upside-down?>> [
+ dup dim>> first 4 * '[
+ _ <groups> reverse concat
+ ] change-bitmap
+ f >>upside-down?
+ ] when ;
+
+PRIVATE>
+
+: normalize-image ( image -- image )
+ [ >byte-array ] change-bitmap
+ normalize-component-order
+ normalize-scan-line-order
+ RGBA >>component-order ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs concurrency.mailboxes io kernel namespaces
+strings words.symbol irc.client.chats irc.messages ;
+EXCLUDE: sequences => join ;
+IN: irc.client.base
+
+SYMBOL: current-irc-client
+
+: irc> ( -- irc-client ) current-irc-client get ;
+: stream> ( -- stream ) irc> stream>> ;
+: irc-print ( s -- ) stream> [ stream-print ] [ stream-flush ] bi ;
+: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
+: chats> ( -- seq ) irc> chats>> values ;
+: me? ( string -- ? ) irc> nick>> = ;
+
+: with-irc ( irc-client quot: ( -- ) -- )
+ \ current-irc-client swap with-variable ; inline
+
+UNION: to-target privmsg notice ;
+UNION: to-channel join part topic kick rpl-channel-modes
+ rpl-notopic rpl-topic rpl-names rpl-names-end ;
+UNION: to-one-chat to-target to-channel mode ;
+UNION: to-many-chats nick quit ;
+UNION: to-all-chats irc-end irc-disconnected irc-connected ;
+PREDICATE: to-me < to-target target>> me? ;
+
+GENERIC: chat-name ( irc-message -- name )
+M: mode chat-name name>> ;
+M: to-target chat-name target>> ;
+M: to-me chat-name sender>> ;
+M: to-channel chat-name channel>> ;
+
+GENERIC: chat> ( obj -- chat/f )
+M: string chat> irc> chats>> at ;
+M: symbol chat> irc> chats>> at ;
+M: to-one-chat chat> chat-name +server-chat+ or chat> ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax quotations kernel ;
+IN: irc.client.chats
+
+HELP: irc-client "IRC Client object" ;
+
+HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ;
+
+HELP: irc-channel-chat "Chat for irc channels" ;
+
+HELP: irc-nick-chat "Chat for irc users" ;
+
+HELP: irc-profile "IRC Client profile object" ;
+
+HELP: irc-chat-end "Message sent to a chat when it has been detached from the client, the chat should stop after it receives this message." ;
+
+HELP: irc-end "Message sent when the client isn't running anymore, the chat should stop after it receives this message." ;
+
+HELP: irc-disconnected "Message sent to notify chats that connection was lost." ;
+
+HELP: irc-connected "Message sent to notify chats that a connection with the irc server was established." ;
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors concurrency.mailboxes kernel calendar io.sockets io.encodings.8-bit
+destructors arrays sequences ;
+IN: irc.client.chats
+
+CONSTANT: irc-port 6667 ! Default irc port
+
+TUPLE: irc-chat in-messages client ;
+TUPLE: irc-server-chat < irc-chat ;
+TUPLE: irc-channel-chat < irc-chat name password participants clear-participants ;
+TUPLE: irc-nick-chat < irc-chat name ;
+SYMBOL: +server-chat+
+
+: <irc-server-chat> ( -- irc-server-chat )
+ irc-server-chat new
+ <mailbox> >>in-messages ;
+
+: <irc-channel-chat> ( name -- irc-channel-chat )
+ irc-channel-chat new
+ swap >>name
+ <mailbox> >>in-messages
+ f >>password
+ H{ } clone >>participants
+ t >>clear-participants ;
+
+: <irc-nick-chat> ( name -- irc-nick-chat )
+ irc-nick-chat new
+ swap >>name
+ <mailbox> >>in-messages ;
+
+TUPLE: irc-profile server port nickname password ;
+C: <irc-profile> irc-profile
+
+TUPLE: irc-client profile stream in-messages out-messages
+ chats is-running nick connect reconnect-time is-ready
+ exceptions ;
+
+: <irc-client> ( profile -- irc-client )
+ dup nickname>> irc-client new
+ swap >>nick
+ swap >>profile
+ <mailbox> >>in-messages
+ <mailbox> >>out-messages
+ H{ } clone >>chats
+ 15 seconds >>reconnect-time
+ V{ } clone >>exceptions
+ [ <inet> latin1 <client> ] >>connect ;
+
+SINGLETONS: irc-chat-end irc-end irc-disconnected irc-connected ;
--- /dev/null
+IRC Client and Chat object definitions
-USING: help.markup help.syntax quotations kernel irc.messages ;
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax quotations kernel
+irc.messages irc.messages.base irc.messages.parser irc.client.chats ;
IN: irc.client
-HELP: irc-client "IRC Client object" ;
-
-HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ;
-
-HELP: irc-channel-chat "Chat for irc channels" ;
-
-HELP: irc-nick-chat "Chat for irc users" ;
-
-HELP: irc-profile "IRC Client profile object" ;
-
HELP: connect-irc "Connecting to an irc server"
{ $values { "irc-client" "an irc client object" } }
{ $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ;
"Some of the RFC defined irc messages as objects:"
{ $table
{ { $link irc-message } "base of all irc messages" }
- { { $link logged-in } "logged in to server" }
+ { { $link rpl-welcome } "logged in to server" }
{ { $link ping } "ping message" }
{ { $link join } "channel join" }
{ { $link part } "channel part" }
{ { $link quit } "quit from irc" }
{ { $link privmsg } "private message (to client or channel)" }
{ { $link kick } "kick from channel" }
- { { $link roomlist } "list of participants in channel" }
- { { $link nick-in-use } "chosen nick is in use by another client" }
+ { { $link rpl-names } "list of participants in channel" }
+ { { $link rpl-nickname-in-use } "chosen nick is in use by another client" }
{ { $link notice } "notice message" }
{ { $link mode } "mode change" }
{ { $link unhandled } "uninmplemented/unhandled message" }
}
+
{ $heading "Special messages" }
"Some special messages that are created by the library and not by the irc server."
{ $table
{ { $link irc-chat-end } "sent to a chat when it has been detached from the client, the chat should stop after it receives this message. " }
- { { $link irc-end } " sent when the client isn't running anymore, chats should stop after it receives this message." }
+ { { $link irc-end } " sent when the client isn't running anymore, the chat should stop after it receives this message." }
{ { $link irc-disconnected } " sent to notify chats that connection was lost." }
{ { $link irc-connected } " sent to notify chats that a connection with the irc server was established." } }
{ $heading "Example:" }
{ $code
- "USING: irc.client ;"
+ "USING: irc.client irc.client.chats ;"
"SYMBOL: bot"
"SYMBOL: mychannel"
"! Create the profile and client objects"
"! Register and start chat (this joins the channel)"
"mychannel get bot get attach-chat"
"! Send a message to the channel"
- "\"what's up?\" mychannel get speak"
+ "\"Hello World!\" mychannel get speak"
"! Read a message from the channel"
"mychannel get hear"
}
+++ /dev/null
-USING: kernel tools.test accessors arrays sequences
- io io.streams.duplex namespaces threads destructors
- calendar irc.client.private irc.client irc.messages.private
- concurrency.mailboxes classes assocs combinators ;
-EXCLUDE: irc.messages => join ;
-RENAME: join irc.messages => join_
-IN: irc.client.tests
-
-! Streams for testing
-TUPLE: mb-writer lines last-line disposed ;
-TUPLE: mb-reader lines disposed ;
-: <mb-writer> ( -- mb-writer ) V{ } clone V{ } clone f mb-writer boa ;
-: <mb-reader> ( -- mb-reader ) <mailbox> f mb-reader boa ;
-: push-line ( line test-reader-stream -- ) lines>> mailbox-put ;
-: <test-stream> ( -- stream ) <mb-reader> <mb-writer> <duplex-stream> ;
-M: mb-writer stream-write ( line mb-writer -- ) last-line>> push ;
-M: mb-writer stream-flush ( mb-writer -- ) drop ;
-M: mb-reader stream-readln ( mb-reader -- str/f ) lines>> mailbox-get ;
-M: mb-writer stream-nl ( mb-writer -- )
- [ [ last-line>> concat ] [ lines>> ] bi push ] keep
- V{ } clone >>last-line drop ;
-M: mb-reader dispose f swap push-line ;
-M: mb-writer dispose drop ;
-
-: spawn-client ( -- irc-client )
- "someserver" irc-port "factorbot" f <irc-profile>
- <irc-client>
- t >>is-ready
- t >>is-running
- <test-stream> >>stream
- dup [ spawn-irc yield ] with-irc-client ;
-
-! to be used inside with-irc-client quotations
-: %add-named-chat ( chat -- ) irc> attach-chat ;
-: %push-line ( line -- ) irc> stream>> in>> push-line yield ;
-: %join ( channel -- ) <irc-channel-chat> irc> attach-chat ;
-
-: read-matching-message ( chat quot: ( msg -- ? ) -- irc-message )
- [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
-
-: with-irc ( quot: ( -- ) -- )
- [ spawn-client ] dip [ irc> terminate-irc ] compose with-irc-client ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! TESTS
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[ { t } [ irc> nick>> me? ] unit-test
-
- { "factorbot" } [ irc> nick>> ] unit-test
-
- { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
-
- { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
- parse-irc-line forward-name ] unit-test
-
- { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
- parse-irc-line forward-name ] unit-test
-] with-irc
-
-! Test login and nickname set
-[ { "factorbot2" } [
- ":some.where 001 factorbot2 :Welcome factorbot2" %push-line
- irc> nick>>
- ] unit-test
-] with-irc
-
-! Test connect
-{ V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
- "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
- [ 2drop <test-stream> t ] >>connect
- [ connect-irc ] [ stream>> out>> lines>> ] [ terminate-irc ] tri
-] unit-test
-
-! Test join
-[ { "JOIN #factortest" } [
- "#factortest" %join
- irc> stream>> out>> lines>> pop
- ] unit-test
-] with-irc
-
-[ { join_ "#factortest" } [
- "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
- { ":factorbot!n=factorbo@some.where JOIN :#factortest"
- ":ircserver.net 353 factorbot @ #factortest :@factorbot "
- ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
- ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
- } [ %push-line ] each
- in-messages>> 0.1 seconds mailbox-get-timeout
- [ class ] [ trailing>> ] bi
- ] unit-test
-] with-irc
-
-[ { T{ participant-changed f "somebody" +join+ } } [
- "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
- ":somebody!n=somebody@some.where JOIN :#factortest" %push-line
- [ participant-changed? ] read-matching-message
- ] unit-test
-] with-irc
-
-[ { privmsg "#factortest" "hello" } [
- "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
- ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line
- [ privmsg? ] read-matching-message
- [ class ] [ name>> ] [ trailing>> ] tri
- ] unit-test
-] with-irc
-
-[ { privmsg "factorbot" "hello" } [
- "ircuser" <irc-nick-chat> [ %add-named-chat ] keep
- ":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line
- [ privmsg? ] read-matching-message
- [ class ] [ name>> ] [ trailing>> ] tri
- ] unit-test
-] with-irc
-
-[ { mode } [
- "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
- ":ircserver.net MODE #factortest +ns" %push-line
- [ mode? ] read-matching-message class
- ] unit-test
-] with-irc
-
-! Participant lists tests
-[ { H{ { "ircuser" +normal+ } } } [
- "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
- ":ircuser!n=user@isp.net JOIN :#factortest" %push-line
- participants>>
- ] unit-test
-] with-irc
-
-[ { H{ { "ircuser2" +normal+ } } } [
- "#factortest" <irc-channel-chat>
- H{ { "ircuser2" +normal+ }
- { "ircuser" +normal+ } } clone >>participants
- [ %add-named-chat ] keep
- ":ircuser!n=user@isp.net PART #factortest" %push-line
- participants>>
- ] unit-test
-] with-irc
-
-[ { H{ { "ircuser2" +normal+ } } } [
- "#factortest" <irc-channel-chat>
- H{ { "ircuser2" +normal+ }
- { "ircuser" +normal+ } } clone >>participants
- [ %add-named-chat ] keep
- ":ircuser!n=user@isp.net QUIT" %push-line
- participants>>
- ] unit-test
-] with-irc
-
-[ { H{ { "ircuser2" +normal+ } } } [
- "#factortest" <irc-channel-chat>
- H{ { "ircuser2" +normal+ }
- { "ircuser" +normal+ } } clone >>participants
- [ %add-named-chat ] keep
- ":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line
- participants>>
- ] unit-test
-] with-irc
-
-[ { H{ { "ircuser2" +normal+ } } } [
- "#factortest" <irc-channel-chat>
- H{ { "ircuser" +normal+ } } clone >>participants
- [ %add-named-chat ] keep
- ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
- participants>>
- ] unit-test
-] with-irc
-
-[ { H{ { "factorbot" +operator+ } { "ircuser" +normal+ } } } [
- "#factortest" <irc-channel-chat>
- H{ { "ircuser" +normal+ } } clone >>participants
- [ %add-named-chat ] keep
- ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
- ":ircserver.net 353 factorbot @ #factortest :ircuser2 " %push-line
- ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
- ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
- ":ircserver.net 353 factorbot @ #factortest :ircuser " %push-line
- ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
- participants>>
- ] unit-test
-] with-irc
-
-! Namelist change notification
-[ { T{ participant-changed f f f f } } [
- "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
- ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
- ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
- [ participant-changed? ] read-matching-message
- ] unit-test
-] with-irc
-
-[ { T{ participant-changed f "ircuser" +part+ f } } [
- "#factortest" <irc-channel-chat>
- H{ { "ircuser" +normal+ } } clone >>participants
- [ %add-named-chat ] keep
- ":ircuser!n=user@isp.net QUIT" %push-line
- [ participant-changed? ] read-matching-message
- ] unit-test
-] with-irc
-
-[ { T{ participant-changed f "ircuser" +nick+ "ircuser2" } } [
- "#factortest" <irc-channel-chat>
- H{ { "ircuser" +normal+ } } clone >>participants
- [ %add-named-chat ] keep
- ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
- [ participant-changed? ] read-matching-message
- ] unit-test
-] with-irc
-
-! Mode change
-[ { T{ participant-changed f "ircuser" +mode+ "+o" } } [
- "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
- ":ircserver.net MODE #factortest +o ircuser" %push-line
- [ participant-changed? ] read-matching-message
- ] unit-test
-] with-irc
! Copyright (C) 2008 Bruno Deferrari, Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
- accessors destructors namespaces io assocs arrays fry
- continuations threads strings classes combinators splitting hashtables
- ascii irc.messages ;
-RENAME: join sequences => sjoin
-EXCLUDE: sequences => join ;
+USING: accessors concurrency.mailboxes destructors
+irc.client.base irc.client.chats irc.client.internals kernel
+namespaces sequences ;
IN: irc.client
-! ======================================
-! Setup and running objects
-! ======================================
-
-CONSTANT: irc-port 6667 ! Default irc port
-
-TUPLE: irc-profile server port nickname password ;
-C: <irc-profile> irc-profile
-
-TUPLE: irc-client profile stream in-messages out-messages
- chats is-running nick connect reconnect-time is-ready ;
-
-: <irc-client> ( profile -- irc-client )
- irc-client new
- swap >>profile
- <mailbox> >>in-messages
- <mailbox> >>out-messages
- H{ } clone >>chats
- dup profile>> nickname>> >>nick
- [ <inet> latin1 <client> ] >>connect
- 15 seconds >>reconnect-time ;
-
-TUPLE: irc-chat in-messages client ;
-TUPLE: irc-server-chat < irc-chat ;
-TUPLE: irc-channel-chat < irc-chat name password timeout participants clean-participants ;
-TUPLE: irc-nick-chat < irc-chat name ;
-SYMBOL: +server-chat+
-
-! participant modes
-SYMBOL: +operator+
-SYMBOL: +voice+
-SYMBOL: +normal+
-
-: participant-mode ( n -- mode )
- H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ;
-
-! participant changed actions
-SYMBOL: +join+
-SYMBOL: +part+
-SYMBOL: +mode+
-SYMBOL: +nick+
-
-! chat objects
-: <irc-server-chat> ( -- irc-server-chat )
- <mailbox> f irc-server-chat boa ;
-
-: <irc-channel-chat> ( name -- irc-channel-chat )
- [ <mailbox> f ] dip f 60 seconds H{ } clone t
- irc-channel-chat boa ;
-
-: <irc-nick-chat> ( name -- irc-nick-chat )
- [ <mailbox> f ] dip irc-nick-chat boa ;
-
-! ======================================
-! Message objects
-! ======================================
-
-TUPLE: participant-changed nick action parameter ;
-C: <participant-changed> participant-changed
-
-SINGLETON: irc-chat-end ! sent to a chat to stop its execution
-SINGLETON: irc-end ! sent when the client isn't running anymore
-SINGLETON: irc-disconnected ! sent when connection is lost
-SINGLETON: irc-connected ! sent when connection is established
-
-: terminate-irc ( irc-client -- )
- [ is-running>> ] keep and [
- f >>is-running
- [ stream>> dispose ] keep
- [ in-messages>> ] [ out-messages>> ] bi 2array
- [ irc-end swap mailbox-put ] each
- ] when* ;
-
-<PRIVATE
-
-SYMBOL: current-irc-client
-
-! ======================================
-! Utils
-! ======================================
-
-: irc> ( -- irc-client ) current-irc-client get ;
-: irc-write ( s -- ) irc> stream>> stream-write ;
-: irc-print ( s -- ) irc> stream>> [ stream-print ] keep stream-flush ;
-: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
-: chat> ( name -- chat/f ) irc> chats>> at ;
-: channel-mode? ( mode -- ? ) name>> first "#&" member? ;
-: me? ( string -- ? ) irc> nick>> = ;
-
-GENERIC: to-chat ( message obj -- )
-
-M: string to-chat
- chat> [ +server-chat+ chat> ] unless*
- [ to-chat ] [ drop ] if* ;
-
-M: irc-chat to-chat in-messages>> mailbox-put ;
-
-: unregister-chat ( name -- )
- irc> chats>>
- [ at [ irc-chat-end ] dip to-chat ]
- [ delete-at ]
- 2bi ;
-
-: (remove-participant) ( nick chat -- )
- [ participants>> delete-at ]
- [ [ +part+ f <participant-changed> ] dip to-chat ] 2bi ;
-
-: remove-participant ( nick channel -- )
- chat> [ (remove-participant) ] [ drop ] if* ;
-
-: chats-with-participant ( nick -- seq )
- irc> chats>> values
- [ [ irc-channel-chat? ] keep and [ participants>> key? ] [ drop f ] if* ]
- with filter ;
-
-: to-chats-with-participant ( message nickname -- )
- chats-with-participant [ to-chat ] with each ;
-
-: remove-participant-from-all ( nick -- )
- dup chats-with-participant [ (remove-participant) ] with each ;
-
-: notify-rename ( newnick oldnick chat -- )
- [ participant-changed new +nick+ >>action
- [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-chat ;
-
-: rename-participant ( newnick oldnick chat -- )
- [ participants>> [ delete-at* drop ] [ swapd set-at ] bi ]
- [ notify-rename ] 3bi ;
-
-: rename-participant-in-all ( oldnick newnick -- )
- swap dup chats-with-participant [ rename-participant ] with with each ;
-
-: add-participant ( mode nick channel -- )
- chat>
- [ participants>> set-at ]
- [ [ +join+ f <participant-changed> ] dip to-chat ] 2bi ;
-
-: change-participant-mode ( channel mode nick -- )
- rot chat>
- [ participants>> set-at ]
- [ [ participant-changed new
- [ (>>nick) ] [ (>>parameter) ] [ +mode+ >>action ] tri ] dip to-chat ]
- 3bi ; ! FIXME
-
-! ======================================
-! IRC client messages
-! ======================================
-
-: /NICK ( nick -- )
- "NICK " irc-write irc-print ;
-
-: /LOGIN ( nick -- )
- dup /NICK
- "USER " irc-write irc-write
- " hostname servername :irc.factor" irc-print ;
-
-: /CONNECT ( server port -- stream )
- irc> connect>> call drop ; inline
-
-: /JOIN ( channel password -- )
- "JOIN " irc-write
- [ [ " :" ] dip 3append ] when* irc-print ;
-
-: /PONG ( text -- )
- "PONG " irc-write irc-print ;
-
-! ======================================
-! Server message handling
-! ======================================
-
-GENERIC: initialize-chat ( chat -- )
-M: irc-chat initialize-chat drop ;
-M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ;
-
-GENERIC: forward-name ( irc-message -- name )
-M: join forward-name trailing>> ;
-M: part forward-name channel>> ;
-M: kick forward-name channel>> ;
-M: mode forward-name name>> ;
-M: privmsg forward-name dup name>> me? [ irc-message-sender ] [ name>> ] if ;
-
-UNION: single-forward join part kick mode privmsg ;
-UNION: multiple-forward nick quit ;
-UNION: broadcast-forward irc-end irc-disconnected irc-connected ;
-GENERIC: forward-message ( irc-message -- )
-
-M: irc-message forward-message
- +server-chat+ chat> [ to-chat ] [ drop ] if* ;
-
-M: single-forward forward-message dup forward-name to-chat ;
-
-M: multiple-forward forward-message
- dup irc-message-sender to-chats-with-participant ;
-
-M: broadcast-forward forward-message
- irc> chats>> values [ to-chat ] with each ;
-
-GENERIC: process-message ( irc-message -- )
-M: object process-message drop ;
-M: logged-in process-message
- name>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri
- values [ initialize-chat ] each ;
-M: ping process-message trailing>> /PONG ;
-M: nick-in-use process-message name>> "_" append /NICK ;
-
-M: join process-message
- [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri
- dup chat> [ add-participant ] [ 3drop ] if ;
-
-M: part process-message
- [ irc-message-sender ] [ channel>> ] bi remove-participant ;
-
-M: kick process-message
- [ [ who>> ] [ channel>> ] bi remove-participant ]
- [ dup who>> me? [ unregister-chat ] [ drop ] if ]
- bi ;
-
-M: quit process-message
- irc-message-sender remove-participant-from-all ;
-
-M: nick process-message
- [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
-
-M: mode process-message ( mode -- )
- [ channel-mode? ] keep and [
- [ name>> ] [ mode>> ] [ parameter>> ] tri
- [ change-participant-mode ] [ 2drop ] if*
- ] when* ;
-
-: >nick/mode ( string -- nick mode )
- dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
-
-: names-reply>participants ( names-reply -- participants )
- trailing>> [ blank? ] trim " " split
- [ >nick/mode 2array ] map >hashtable ;
-
-: maybe-clean-participants ( channel-chat -- )
- dup clean-participants>> [
- H{ } clone >>participants f >>clean-participants
- ] when drop ;
-
-M: names-reply process-message
- [ names-reply>participants ] [ channel>> chat> ] bi [
- [ maybe-clean-participants ]
- [ participants>> 2array assoc-combine ]
- [ (>>participants) ] tri
- ] [ drop ] if* ;
-
-M: end-of-names process-message
- channel>> chat> [
- t >>clean-participants
- [ f f f <participant-changed> ] dip name>> to-chat
- ] when* ;
-
-! ======================================
-! Client message handling
-! ======================================
-
-GENERIC: handle-outgoing-irc ( irc-message -- ? )
-M: irc-end handle-outgoing-irc drop f ;
-M: irc-message handle-outgoing-irc irc-message>client-line irc-print t ;
-
-! ======================================
-! Reader/Writer
-! ======================================
-
-: handle-reader-message ( irc-message -- )
- irc> in-messages>> mailbox-put ;
-
-DEFER: (connect-irc)
-
-: (handle-disconnect) ( -- )
- irc>
- [ [ irc-disconnected ] dip in-messages>> mailbox-put ]
- [ dup reconnect-time>> sleep (connect-irc) ]
- [ nick>> /LOGIN ]
- tri ;
-
-! FIXME: do something with the exception, store somewhere to help debugging
-: handle-disconnect ( error -- ? )
- drop irc> is-running>> [ (handle-disconnect) t ] [ f ] if ;
-
-: (reader-loop) ( -- ? )
- irc> stream>> [
- |dispose stream-readln [
- parse-irc-line handle-reader-message t
- ] [
- handle-disconnect
- ] if*
- ] with-destructors ;
-
-: reader-loop ( -- ? )
- [ (reader-loop) ] [ handle-disconnect ] recover ;
-
-: writer-loop ( -- ? )
- irc> out-messages>> mailbox-get handle-outgoing-irc ;
-
-! ======================================
-! Processing loops
-! ======================================
-
-: in-multiplexer-loop ( -- ? )
- irc> in-messages>> mailbox-get
- [ forward-message ] [ process-message ] [ irc-end? not ] tri ;
-
-: strings>privmsg ( name string -- privmsg )
- privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
-
-: maybe-annotate-with-name ( name obj -- obj )
- { { [ dup string? ] [ strings>privmsg ] }
- { [ dup privmsg instance? ] [ swap >>name ] }
- [ nip ]
- } cond ;
-
-GENERIC: annotate-message ( chat object -- object )
-M: object annotate-message nip ;
-M: part annotate-message swap name>> >>channel ;
-M: privmsg annotate-message swap name>> >>name ;
-M: string annotate-message [ name>> ] dip strings>privmsg ;
-
-: spawn-irc ( -- )
- [ reader-loop ] "irc-reader-loop" spawn-server
- [ writer-loop ] "irc-writer-loop" spawn-server
- [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
- 3drop ;
-
-GENERIC: (attach-chat) ( irc-chat -- )
-USE: prettyprint
-M: irc-chat (attach-chat)
- [ [ irc> >>client ] [ name>> ] bi irc> chats>> set-at ]
- [ [ irc> is-ready>> ] dip and [ initialize-chat ] when* ]
- bi ;
-
-M: irc-server-chat (attach-chat)
- irc> >>client +server-chat+ irc> chats>> set-at ;
-
-GENERIC: (remove-chat) ( irc-chat -- )
-
-M: irc-nick-chat (remove-chat)
- name>> unregister-chat ;
-
-M: irc-channel-chat (remove-chat)
- [ part new annotate-message irc> out-messages>> mailbox-put ] keep
- name>> unregister-chat ;
-
-M: irc-server-chat (remove-chat)
- drop +server-chat+ unregister-chat ;
-
-: (connect-irc) ( irc-client -- )
- {
- [ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
- [ (>>stream) ]
- [ t swap (>>is-running) ]
- [ in-messages>> [ irc-connected ] dip mailbox-put ]
- } cleave ;
-
-: with-irc-client ( irc-client quot: ( -- ) -- )
- [ \ current-irc-client ] dip with-variable ; inline
-
-PRIVATE>
-
: connect-irc ( irc-client -- )
- dup [ [ (connect-irc) ] [ nick>> /LOGIN ] bi spawn-irc ] with-irc-client ;
-
-: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc-client ;
-
-: detach-chat ( irc-chat -- )
- [ client>> ] keep '[ _ (remove-chat) ] with-irc-client ;
-
-: speak ( message irc-chat -- )
- [ swap annotate-message ] [ client>> out-messages>> mailbox-put ] bi ;
+ [ (connect-irc) (do-login) spawn-irc ] with-irc ;
+: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc ;
+: detach-chat ( irc-chat -- ) dup [ client>> remove-chat ] with-irc ;
+: speak ( message irc-chat -- ) dup client>> [ (speak) ] with-irc ;
: hear ( irc-chat -- message ) in-messages>> mailbox-get ;
+: terminate-irc ( irc-client -- ) [ (terminate-irc) ] with-irc ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel tools.test accessors arrays sequences
+io io.streams.duplex namespaces threads destructors
+calendar concurrency.mailboxes classes assocs combinators
+irc.messages.parser irc.client.base irc.client.chats
+irc.client.participants irc.client.internals ;
+EXCLUDE: irc.messages => join ;
+RENAME: join irc.messages => join_
+IN: irc.client.internals.tests
+
+! Streams for testing
+TUPLE: mb-writer lines last-line disposed ;
+TUPLE: mb-reader lines disposed ;
+: <mb-writer> ( -- mb-writer ) V{ } clone V{ } clone f mb-writer boa ;
+: <mb-reader> ( -- mb-reader ) <mailbox> f mb-reader boa ;
+: push-line ( line test-reader-stream -- ) lines>> mailbox-put ;
+: <test-stream> ( -- stream ) <mb-reader> <mb-writer> <duplex-stream> ;
+M: mb-writer stream-write ( line mb-writer -- ) last-line>> push ;
+M: mb-writer stream-flush ( mb-writer -- ) drop ;
+M: mb-reader stream-readln ( mb-reader -- str/f ) lines>> mailbox-get ;
+M: mb-writer stream-nl ( mb-writer -- )
+ [ [ last-line>> concat ] [ lines>> ] bi push ] keep
+ V{ } clone >>last-line drop ;
+M: mb-reader dispose f swap push-line ;
+M: mb-writer dispose drop ;
+
+: spawn-client ( -- irc-client )
+ "someserver" irc-port "factorbot" f <irc-profile>
+ <irc-client>
+ t >>is-ready
+ t >>is-running
+ <test-stream> >>stream
+ dup [ spawn-irc yield ] with-irc ;
+
+! to be used inside with-irc quotations
+: %add-named-chat ( chat -- ) (attach-chat) ;
+: %push-line ( line -- ) irc> stream>> in>> push-line yield ;
+: %push-lines ( lines -- ) [ %push-line ] each ;
+: %join ( channel -- ) <irc-channel-chat> (attach-chat) ;
+: %pop-output-line ( -- string ) irc> stream>> out>> lines>> pop ;
+
+: read-matching-message ( chat quot: ( msg -- ? ) -- irc-message )
+ [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
+
+: spawning-irc ( quot: ( -- ) -- )
+ [ spawn-client ] dip [ (terminate-irc) ] compose with-irc ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! TESTS
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+[ { t } [ irc> nick>> me? ] unit-test
+
+ { "factorbot" } [ irc> nick>> ] unit-test
+
+ { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
+ string>irc-message chat-name ] unit-test
+
+ { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
+ string>irc-message chat-name ] unit-test
+] spawning-irc
+
+{ privmsg "#channel" "hello" } [
+ "#channel" "hello" strings>privmsg
+ [ class ] [ target>> ] [ trailing>> ] tri
+] unit-test
+
+! Test login and nickname set
+[ { "factorbot2" } [
+ ":some.where 001 factorbot2 :Welcome factorbot2" %push-line
+ irc> nick>>
+ ] unit-test
+] spawning-irc
+
+! Test connect
+{ V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
+ "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
+ [ 2drop <test-stream> t ] >>connect
+ [
+ (connect-irc)
+ (do-login)
+ irc> stream>> out>> lines>>
+ (terminate-irc)
+ ] with-irc
+] unit-test
+
+! Test join
+[ { "JOIN #factortest" } [
+ "#factortest" %join %pop-output-line
+ ] unit-test
+] spawning-irc
+
+[ { join_ "#factortest"} [
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
+ { ":factorbot!n=factorbo@some.where JOIN :#factortest"
+ ":ircserver.net 353 factorbot @ #factortest :@factorbot "
+ ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
+ ":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
+ } %push-lines
+ [ join? ] read-matching-message
+ [ class ] [ channel>> ] bi
+ ] unit-test
+] spawning-irc
+
+[ { privmsg "#factortest" "hello" } [
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
+ ":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line
+ [ privmsg? ] read-matching-message
+ [ class ] [ target>> ] [ trailing>> ] tri
+ ] unit-test
+] spawning-irc
+
+[ { privmsg "factorbot" "hello" } [
+ "ircuser" <irc-nick-chat> [ %add-named-chat ] keep
+ ":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line
+ [ privmsg? ] read-matching-message
+ [ class ] [ target>> ] [ trailing>> ] tri
+ ] unit-test
+] spawning-irc
+
+[ { mode "#factortest" "+ns" } [
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
+ ":ircserver.net MODE #factortest +ns" %push-line
+ [ mode? ] read-matching-message
+ [ class ] [ name>> ] [ mode>> ] tri
+ ] unit-test
+] spawning-irc
+
+! Participant lists tests
+[ { { "ircuser" } } [
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
+ ":ircuser!n=user@isp.net JOIN :#factortest" %push-line
+ participants>> keys
+ ] unit-test
+] spawning-irc
+
+[ { { "ircuser2" } } [
+ "#factortest" <irc-channel-chat>
+ { "ircuser2" "ircuser" } [ over join-participant ] each
+ [ %add-named-chat ] keep
+ ":ircuser!n=user@isp.net PART #factortest" %push-line
+ participants>> keys
+ ] unit-test
+] spawning-irc
+
+[ { { "ircuser2" } } [
+ "#factortest" <irc-channel-chat>
+ { "ircuser2" "ircuser" } [ over join-participant ] each
+ [ %add-named-chat ] keep
+ ":ircuser!n=user@isp.net QUIT" %push-line
+ participants>> keys
+ ] unit-test
+] spawning-irc
+
+[ { { "ircuser2" } } [
+ "#factortest" <irc-channel-chat>
+ { "ircuser2" "ircuser" } [ over join-participant ] each
+ [ %add-named-chat ] keep
+ ":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line
+ participants>> keys
+ ] unit-test
+] spawning-irc
+
+[ { H{ { "ircuser2" T{ participant { nick "ircuser2" } } } } } [
+ "#factortest" <irc-channel-chat>
+ "ircuser" over join-participant
+ [ %add-named-chat ] keep
+ ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
+ participants>>
+ ] unit-test
+] spawning-irc
+
+[ { H{ { "factorbot" T{ participant { nick "factorbot" } { operator t } } }
+ { "ircuser" T{ participant { nick "ircuser" } } }
+ { "voiced" T{ participant { nick "voiced" } { voice t } } } } } [
+ "#factortest" <irc-channel-chat>
+ "ircuser" over join-participant
+ [ %add-named-chat ] keep
+ { ":ircserver.net 353 factorbot @ #factortest :@factorbot "
+ ":ircserver.net 353 factorbot @ #factortest :ircuser2 "
+ ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
+ ":ircserver.net 353 factorbot @ #factortest :@factorbot +voiced "
+ ":ircserver.net 353 factorbot @ #factortest :ircuser "
+ ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
+ } %push-lines
+ participants>>
+ ] unit-test
+] spawning-irc
+
+[ { mode "#factortest" "+o" "ircuser" } [
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
+ "ircuser" over join-participant
+ ":ircserver.net MODE #factortest +o ircuser" %push-line
+ [ mode? ] read-matching-message
+ { [ class ] [ name>> ] [ mode>> ] [ parameter>> ] } cleave
+ ] unit-test
+] spawning-irc
+
+[ { T{ participant { nick "ircuser" } { operator t } } } [
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
+ "ircuser" over join-participant
+ ":ircserver.net MODE #factortest +o ircuser" %push-line
+ participants>> "ircuser" swap at
+ ] unit-test
+] spawning-irc
+
+! Send privmsg
+[ { "PRIVMSG #factortest :hello" } [
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
+ "hello" swap (speak) %pop-output-line
+ ] unit-test
+] spawning-irc
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs arrays concurrency.mailboxes continuations destructors
+hashtables io irc.client.base irc.client.chats irc.messages kernel namespaces
+strings words.symbol irc.messages.base irc.client.participants fry threads
+combinators irc.messages.parser ;
+EXCLUDE: sequences => join ;
+IN: irc.client.internals
+
+: /NICK ( nick -- ) "NICK " prepend irc-print ;
+: /PONG ( text -- ) "PONG " prepend irc-print ;
+
+: /LOGIN ( nick -- )
+ dup /NICK
+ "USER " prepend " hostname servername :irc.factor" append irc-print ;
+
+: /CONNECT ( server port -- stream )
+ irc> connect>> call( host port -- stream local ) drop ;
+
+: /JOIN ( channel password -- )
+ [ " :" swap 3append ] when* "JOIN " prepend irc-print ;
+
+: (connect-irc) ( -- )
+ irc> {
+ [ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
+ [ (>>stream) ]
+ [ t swap (>>is-running) ]
+ [ in-messages>> [ irc-connected ] dip mailbox-put ]
+ } cleave ;
+
+: (do-login) ( -- ) irc> nick>> /LOGIN ;
+
+GENERIC: initialize-chat ( chat -- )
+M: irc-chat initialize-chat drop ;
+M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ;
+
+GENERIC: chat-put ( message obj -- )
+M: irc-chat chat-put in-messages>> mailbox-put ;
+M: symbol chat-put chat> [ chat-put ] [ drop ] if* ;
+M: string chat-put chat> +server-chat+ or chat-put ;
+M: sequence chat-put [ chat-put ] with each ;
+
+: delete-chat ( name -- ) irc> chats>> delete-at ;
+: unregister-chat ( name -- ) [ irc-chat-end chat-put ] [ delete-chat ] bi ;
+
+! Server message handling
+
+GENERIC: message-forwards ( irc-message -- seq )
+M: irc-message message-forwards drop +server-chat+ ;
+M: to-one-chat message-forwards chat> ;
+M: to-all-chats message-forwards drop chats> ;
+M: to-many-chats message-forwards sender>> participant-chats ;
+
+GENERIC: process-message ( irc-message -- )
+M: object process-message drop ;
+M: ping process-message trailing>> /PONG ;
+M: join process-message [ sender>> ] [ chat> ] bi join-participant ;
+M: part process-message [ sender>> ] [ chat> ] bi part-participant ;
+M: quit process-message sender>> quit-participant ;
+M: nick process-message [ trailing>> ] [ sender>> ] bi rename-participant* ;
+M: rpl-nickname-in-use process-message name>> "_" append /NICK ;
+
+M: rpl-welcome process-message
+ irc>
+ swap nickname>> >>nick
+ t >>is-ready
+ chats>> values [ initialize-chat ] each ;
+
+M: kick process-message
+ [ [ user>> ] [ chat> ] bi part-participant ]
+ [ dup user>> me? [ unregister-chat ] [ drop ] if ]
+ bi ;
+
+M: participant-mode process-message ( participant-mode -- )
+ [ mode>> ] [ name>> ] [ parameter>> ] tri change-participant-mode ;
+
+M: rpl-names process-message
+ [ nicks>> ] [ chat> ] bi dup ?clear-participants
+ '[ _ join-participant ] each ;
+
+M: rpl-names-end process-message chat> t >>clear-participants drop ;
+
+! Client message handling
+
+GENERIC: handle-outgoing-irc ( irc-message -- ? )
+M: irc-end handle-outgoing-irc drop f ;
+M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
+
+! Reader/Writer
+
+: handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ;
+
+: (handle-disconnect) ( -- )
+ irc-disconnected irc> in-messages>> mailbox-put
+ irc> reconnect-time>> sleep
+ (connect-irc)
+ (do-login) ;
+
+: handle-disconnect ( error -- ? )
+ [ irc> exceptions>> push ] when*
+ irc> is-running>> [ (handle-disconnect) t ] [ f ] if ;
+
+GENERIC: handle-input ( line/f -- ? )
+M: string handle-input string>irc-message handle-reader-message t ;
+M: f handle-input handle-disconnect ;
+
+: (reader-loop) ( -- ? )
+ stream> [ |dispose stream-readln handle-input ] with-destructors ;
+
+: reader-loop ( -- ? ) [ (reader-loop) ] [ handle-disconnect ] recover ;
+: writer-loop ( -- ? ) irc> out-messages>> mailbox-get handle-outgoing-irc ;
+
+! Processing loops
+
+: in-multiplexer-loop ( -- ? )
+ irc> in-messages>> mailbox-get {
+ [ message-forwards ]
+ [ process-message ]
+ [ swap chat-put ]
+ [ irc-end? not ]
+ } cleave ;
+
+: strings>privmsg ( name string -- privmsg )
+ " :" prepend append "PRIVMSG " prepend string>irc-message ;
+
+GENERIC: annotate-message ( chat object -- object )
+M: object annotate-message nip ;
+M: to-channel annotate-message swap name>> >>channel ;
+M: to-target annotate-message swap name>> >>target ;
+M: mode annotate-message swap name>> >>name ;
+M: string annotate-message [ name>> ] dip strings>privmsg ;
+
+: spawn-irc ( -- )
+ [ reader-loop ] "irc-reader-loop" spawn-server
+ [ writer-loop ] "irc-writer-loop" spawn-server
+ [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
+ 3drop ;
+
+GENERIC: (attach-chat) ( irc-chat -- )
+
+M: irc-chat (attach-chat)
+ irc>
+ [ [ chats>> ] [ >>client name>> swap ] 2bi set-at ]
+ [ is-ready>> [ initialize-chat ] [ drop ] if ]
+ 2bi ;
+
+M: irc-server-chat (attach-chat)
+ irc> [ (>>client) ] [ chats>> +server-chat+ set-at ] 2bi ;
+
+GENERIC: remove-chat ( irc-chat -- )
+M: irc-nick-chat remove-chat name>> unregister-chat ;
+M: irc-server-chat remove-chat drop +server-chat+ unregister-chat ;
+
+M: irc-channel-chat remove-chat
+ [ part new annotate-message irc-send ]
+ [ name>> unregister-chat ] bi ;
+
+: (terminate-irc) ( -- )
+ irc> dup is-running>> [
+ f >>is-running
+ [ stream>> dispose ] keep
+ [ in-messages>> ] [ out-messages>> ] bi 2array
+ [ irc-end swap mailbox-put ] each
+ ] [ drop ] if ;
+
+: (speak) ( message irc-chat -- ) swap annotate-message irc-send ;
\ No newline at end of file
--- /dev/null
+IRC Client internals
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators fry hashtables
+irc.client.base irc.client.chats kernel sequences splitting ;
+IN: irc.client.participants
+
+TUPLE: participant nick operator voice ;
+: <participant> ( name -- participant )
+ {
+ { [ "@" ?head ] [ t f ] }
+ { [ "+" ?head ] [ f t ] }
+ [ f f ]
+ } cond participant boa ;
+
+GENERIC: has-participant? ( name irc-chat -- ? )
+M: irc-chat has-participant? 2drop f ;
+M: irc-channel-chat has-participant? participants>> key? ;
+
+: rename-X ( new old assoc quot: ( obj value -- obj ) -- )
+ '[ delete-at* drop swap @ ] [ nip set-at ] 3bi ; inline
+
+: rename-nick-chat ( new old -- ) irc> chats>> [ >>name ] rename-X ;
+: rename-participant ( new old chat -- ) participants>> [ >>nick ] rename-X ;
+: part-participant ( nick irc-chat -- ) participants>> delete-at ;
+: participant-chats ( nick -- seq ) chats> [ has-participant? ] with filter ;
+
+: quit-participant ( nick -- )
+ dup participant-chats [ part-participant ] with each ;
+
+: rename-participant* ( new old -- )
+ [ dup participant-chats [ rename-participant ] with with each ]
+ [ dup chat> [ rename-nick-chat ] [ 2drop ] if ]
+ 2bi ;
+
+: join-participant ( nick irc-channel-chat -- )
+ participants>> [ <participant> dup nick>> ] dip set-at ;
+
+: apply-mode ( ? participant mode -- )
+ {
+ { CHAR: o [ (>>operator) ] }
+ { CHAR: v [ (>>voice) ] }
+ [ 3drop ]
+ } case ;
+
+: apply-modes ( mode-line participant -- )
+ [ unclip CHAR: + = ] dip
+ '[ [ _ _ ] dip apply-mode ] each ;
+
+: change-participant-mode ( mode channel nick -- )
+ swap chat> participants>> at apply-modes ;
+
+: ?clear-participants ( channel-chat -- )
+ dup clear-participants>> [
+ f >>clear-participants participants>> clear-assoc
+ ] [ drop ] if ;
--- /dev/null
+IRC Client chat participants handling
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry irc.client irc.client.private kernel namespaces
+USING: fry irc.client irc.client.chats kernel namespaces
sequences threads io.encodings.8-bit io.launcher io splitting
make mason.common mason.updates calendar math alarms ;
IN: irc.gitbot
--- /dev/null
+Bruno Deferrari
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors irc.messages irc.messages.base kernel make ;
+EXCLUDE: sequences => join ;
+IN: irc.logbot.log-line
+
+: dot-or-parens ( string -- string )
+ [ "." ] [ " (" prepend ")." append ] if-empty ;
+
+GENERIC: >log-line ( object -- line )
+
+M: irc-message >log-line line>> ;
+
+M: privmsg >log-line
+ [ "<" % dup sender>> % "> " % text>> % ] "" make ;
+
+M: join >log-line
+ [ "* " % sender>> % " has joined the channel." % ] "" make ;
+
+M: part >log-line
+ [ "* " % dup sender>> % " has left the channel" %
+ comment>> dot-or-parens % ] "" make ;
+
+M: quit >log-line
+ [ "* " % dup sender>> % " has quit" %
+ comment>> dot-or-parens % ] "" make ;
+
+M: kick >log-line
+ [ "* " % dup sender>> % " has kicked " % dup user>> %
+ " from the channel" % comment>> dot-or-parens % ] "" make ;
+
+M: participant-mode >log-line
+ [ "* " % dup sender>> % " has set mode " % dup mode>> %
+ " to " % parameter>> % ] "" make ;
+
+M: nick >log-line
+ [ "* " % dup sender>> % " is now known as " % nickname>> % ] "" make ;
--- /dev/null
+IRC message formatting for logs
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar calendar.format destructors fry io io.encodings.8-bit
+io.files io.pathnames irc.client irc.client.chats irc.messages
+irc.messages.base kernel make namespaces sequences threads
+irc.logbot.log-line ;
+IN: irc.logbot
+
+CONSTANT: bot-channel "#concatenative"
+CONSTANT: log-directory "/tmp/logs"
+
+SYMBOL: current-day
+SYMBOL: current-stream
+
+: bot-profile ( -- obj )
+ "irc.freenode.org" 6667 "flogger" f <irc-profile> ;
+
+: add-timestamp ( string timestamp -- string )
+ timestamp>hms "[" prepend "] " append prepend ;
+
+: timestamp-path ( timestamp -- path )
+ timestamp>ymd ".log" append log-directory prepend-path ;
+
+: timestamp>stream ( timestamp -- stream )
+ dup day-of-year current-day get = [
+ drop
+ ] [
+ current-stream get [ dispose ] when*
+ [ day-of-year current-day set ]
+ [ timestamp-path latin1 <file-writer> ] bi
+ current-stream set
+ ] if current-stream get ;
+
+: log-message ( string timestamp -- )
+ [ add-timestamp ] [ timestamp>stream ] bi
+ [ stream-print ] [ stream-flush ] bi ;
+
+GENERIC: handle-message ( msg -- )
+
+M: object handle-message drop ;
+M: irc-message handle-message [ >log-line ] [ timestamp>> ] bi log-message ;
+
+: bot-loop ( chat -- ) dup hear handle-message bot-loop ;
+
+: start-bot ( -- )
+ bot-profile <irc-client>
+ [ connect-irc ]
+ [
+ [ bot-channel <irc-channel-chat> ] dip
+ '[ _ [ _ attach-chat ] [ bot-loop ] bi ]
+ "LogBot" spawn drop
+ ] bi ;
+
+: logbot ( -- ) start-bot ;
+
+MAIN: logbot
--- /dev/null
+An IRC logging bot
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes.parser classes.tuple
+ combinators fry generic.parser kernel lexer
+ mirrors namespaces parser sequences splitting strings words ;
+IN: irc.messages.base
+
+TUPLE: irc-message line prefix command parameters trailing timestamp sender ;
+TUPLE: unhandled < irc-message ;
+
+SYMBOL: string-irc-type-mapping
+string-irc-type-mapping [ H{ } clone ] initialize
+
+: register-irc-message-type ( type string -- )
+ string-irc-type-mapping get set-at ;
+
+: irc>type ( string -- irc-message-class )
+ string-irc-type-mapping get at unhandled or ;
+
+GENERIC: irc-trailing-slot ( irc-message -- string/f )
+M: irc-message irc-trailing-slot
+ drop f ;
+
+GENERIC: irc-parameter-slots ( irc-message -- seq )
+M: irc-message irc-parameter-slots
+ drop f ;
+
+GENERIC: process-irc-trailing ( irc-message -- )
+M: irc-message process-irc-trailing
+ dup irc-trailing-slot [
+ swap [ trailing>> swap ] [ <mirror> ] bi set-at
+ ] [ drop ] if* ;
+
+GENERIC: process-irc-prefix ( irc-message -- )
+M: irc-message process-irc-prefix
+ drop ;
+
+<PRIVATE
+: [slot-setter] ( mirror -- quot )
+ '[ [ _ set-at ] [ drop ] if* ] ; inline
+PRIVATE>
+
+GENERIC: process-irc-parameters ( irc-message -- )
+M: irc-message process-irc-parameters
+ dup irc-parameter-slots [
+ swap [ parameters>> swap ] [ <mirror> [slot-setter] ] bi 2each
+ ] [ drop ] if* ;
+
+GENERIC: post-process-irc-message ( irc-message -- )
+M: irc-message post-process-irc-message drop ;
+
+GENERIC: fill-irc-message-slots ( irc-message -- )
+M: irc-message fill-irc-message-slots
+ {
+ [ process-irc-trailing ]
+ [ process-irc-prefix ]
+ [ process-irc-parameters ]
+ [ post-process-irc-message ]
+ } cleave ;
+
+GENERIC: irc-command-string ( irc-message -- string )
+M: irc-message irc-command-string drop f ;
+
+! FIXME: inverse of post-process is missing
+GENERIC: set-irc-parameters ( irc-message -- )
+M: irc-message set-irc-parameters
+ dup irc-parameter-slots
+ [ over <mirror> '[ _ at ] map >>parameters ] when* drop ;
+
+GENERIC: set-irc-trailing ( irc-message -- )
+M: irc-message set-irc-trailing
+ dup irc-trailing-slot [ over <mirror> at >>trailing ] when* drop ;
+
+GENERIC: set-irc-command ( irc-message -- )
+M: irc-message set-irc-command
+ [ irc-command-string ] [ (>>command) ] bi ;
+
+: irc-message>string ( irc-message -- string )
+ {
+ [ prefix>> ]
+ [ command>> ]
+ [ parameters>> " " join ]
+ [ trailing>> dup [ CHAR: : prefix ] when ]
+ } cleave 4array sift " " join ;
+
+<PRIVATE
+: ?define-irc-parameters ( class slot-names -- )
+ dup empty? not [
+ [ \ irc-parameter-slots create-method-in ] dip
+ [ [ "_" = not ] keep and ] map '[ drop _ ] define
+ ] [ 2drop ] if ;
+
+: ?define-irc-trailing ( class slot-name -- )
+ [
+ [ \ irc-trailing-slot create-method-in ] dip
+ first '[ drop _ ] define
+ ] [ drop ] if* ;
+
+: define-irc-class ( class params -- )
+ [ { ":" "_" } member? not ] filter
+ [ irc-message ] dip define-tuple-class ;
+
+: define-irc-parameter-slots ( class params -- )
+ { ":" } split1 [ over ] dip
+ [ ?define-irc-parameters ] [ ?define-irc-trailing ] 2bi* ;
+PRIVATE>
+
+#! SYNTAX:
+#! IRC: type "COMMAND" slot1 ...;
+#! IRC: type "COMMAND" slot1 ... : trailing-slot;
+SYNTAX: IRC: ( name string parameters -- )
+ CREATE-CLASS
+ [ scan-object register-irc-message-type ] keep
+ ";" parse-tokens
+ [ define-irc-class ] [ define-irc-parameter-slots ] 2bi ;
--- /dev/null
+IRC messages base implementation
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test accessors arrays
- irc.messages irc.messages.private ;
+ irc.messages.parser irc.messages ;
EXCLUDE: sequences => join ;
IN: irc.messages.tests
-{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
-
-{ T{ irc-message
- { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
- { prefix "someuser!n=user@some.where" }
- { command "PRIVMSG" }
- { parameters { "#factortest" } }
- { trailing "hi" } } }
-[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
- string>irc-message f >>timestamp ] unit-test
+! { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
{ T{ privmsg
{ line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
{ command "PRIVMSG" }
{ parameters { "#factortest" } }
{ trailing "hi" }
- { name "#factortest" } } }
+ { target "#factortest" }
+ { text "hi" }
+ { sender "someuser" } } }
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
- parse-irc-line f >>timestamp ] unit-test
+ string>irc-message f >>timestamp ] unit-test
{ T{ join
{ line ":someuser!n=user@some.where JOIN :#factortest" }
{ prefix "someuser!n=user@some.where" }
{ command "JOIN" }
{ parameters { } }
- { trailing "#factortest" } } }
+ { trailing "#factortest" }
+ { sender "someuser" }
+ { channel "#factortest" } } }
[ ":someuser!n=user@some.where JOIN :#factortest"
- parse-irc-line f >>timestamp ] unit-test
+ string>irc-message f >>timestamp ] unit-test
{ T{ mode
{ line ":ircserver.net MODE #factortest +ns" }
{ name "#factortest" }
{ mode "+ns" } } }
[ ":ircserver.net MODE #factortest +ns"
- parse-irc-line f >>timestamp ] unit-test
+ string>irc-message f >>timestamp ] unit-test
{ T{ mode
{ line ":ircserver.net MODE #factortest +o someuser" }
{ mode "+o" }
{ parameter "someuser" } } }
[ ":ircserver.net MODE #factortest +o someuser"
- parse-irc-line f >>timestamp ] unit-test
+ string>irc-message f >>timestamp ] unit-test
{ T{ nick
{ line ":someuser!n=user@some.where NICK :someuser2" }
{ prefix "someuser!n=user@some.where" }
{ command "NICK" }
{ parameters { } }
- { trailing "someuser2" } } }
+ { trailing "someuser2" }
+ { sender "someuser" } } }
[ ":someuser!n=user@some.where NICK :someuser2"
- parse-irc-line f >>timestamp ] unit-test
+ string>irc-message f >>timestamp ] unit-test
-{ T{ nick-in-use
+{ T{ rpl-nickname-in-use
{ line ":ircserver.net 433 * nickname :Nickname is already in use" }
{ prefix "ircserver.net" }
{ command "433" }
{ name "nickname" }
{ trailing "Nickname is already in use" } } }
[ ":ircserver.net 433 * nickname :Nickname is already in use"
- parse-irc-line f >>timestamp ] unit-test
\ No newline at end of file
+ string>irc-message f >>timestamp ] unit-test
\ No newline at end of file
-! Copyright (C) 2008 Bruno Deferrari
+! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: kernel fry splitting ascii calendar accessors combinators
- arrays classes.tuple math.order ;
-RENAME: join sequences => sjoin
+arrays classes.tuple math.order words assocs strings irc.messages.base ;
EXCLUDE: sequences => join ;
IN: irc.messages
-TUPLE: irc-message line prefix command parameters trailing timestamp ;
-TUPLE: logged-in < irc-message name ;
-TUPLE: ping < irc-message ;
-TUPLE: join < irc-message ;
-TUPLE: part < irc-message channel ;
-TUPLE: quit < irc-message ;
-TUPLE: nick < irc-message ;
-TUPLE: privmsg < irc-message name ;
-TUPLE: kick < irc-message channel who ;
-TUPLE: roomlist < irc-message channel names ;
-TUPLE: nick-in-use < irc-message name ;
-TUPLE: notice < irc-message type ;
-TUPLE: mode < irc-message name mode parameter ;
-TUPLE: names-reply < irc-message who channel ;
-TUPLE: end-of-names < irc-message who channel ;
-TUPLE: unhandled < irc-message ;
-
-: <irc-client-message> ( command parameters trailing -- irc-message )
- irc-message new
- now >>timestamp
- swap >>trailing
- swap >>parameters
- swap >>command ;
-
-<PRIVATE
-
-GENERIC: command-string>> ( irc-message -- string )
-
-M: irc-message command-string>> ( irc-message -- string ) command>> ;
-M: ping command-string>> ( ping -- string ) drop "PING" ;
-M: join command-string>> ( join -- string ) drop "JOIN" ;
-M: part command-string>> ( part -- string ) drop "PART" ;
-M: quit command-string>> ( quit -- string ) drop "QUIT" ;
-M: nick command-string>> ( nick -- string ) drop "NICK" ;
-M: privmsg command-string>> ( privmsg -- string ) drop "PRIVMSG" ;
-M: notice command-string>> ( notice -- string ) drop "NOTICE" ;
-M: mode command-string>> ( mode -- string ) drop "MODE" ;
-M: kick command-string>> ( kick -- string ) drop "KICK" ;
-
-GENERIC: command-parameters>> ( irc-message -- seq )
-
-M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ;
-M: ping command-parameters>> ( ping -- seq ) drop { } ;
-M: join command-parameters>> ( join -- seq ) drop { } ;
-M: part command-parameters>> ( part -- seq ) channel>> 1array ;
-M: quit command-parameters>> ( quit -- seq ) drop { } ;
-M: nick command-parameters>> ( nick -- seq ) drop { } ;
-M: privmsg command-parameters>> ( privmsg -- seq ) name>> 1array ;
-M: notice command-parameters>> ( norice -- seq ) type>> 1array ;
-M: kick command-parameters>> ( kick -- seq )
- [ channel>> ] [ who>> ] bi 2array ;
-M: mode command-parameters>> ( mode -- seq )
- [ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
-
-GENERIC# >>command-parameters 1 ( irc-message params -- irc-message )
-
-M: irc-message >>command-parameters ( irc-message params -- irc-message )
- drop ;
-
-M: logged-in >>command-parameters ( part params -- part )
- first >>name ;
-
-M: privmsg >>command-parameters ( privmsg params -- privmsg )
- first >>name ;
-
-M: notice >>command-parameters ( notice params -- notice )
- first >>type ;
-
-M: part >>command-parameters ( part params -- part )
- first >>channel ;
-
-M: kick >>command-parameters ( kick params -- kick )
- first2 [ >>channel ] [ >>who ] bi* ;
-
-M: nick-in-use >>command-parameters ( nick-in-use params -- nick-in-use )
- second >>name ;
-
-M: names-reply >>command-parameters ( names-reply params -- names-reply )
- first3 nip [ >>who ] [ >>channel ] bi* ;
-
-M: end-of-names >>command-parameters ( names-reply params -- names-reply )
- first2 [ >>who ] [ >>channel ] bi* ;
-
-M: mode >>command-parameters ( mode params -- mode )
- dup length {
- { 3 [ first3 [ >>name ] [ >>mode ] [ >>parameter ] tri* ] }
- { 2 [ first2 [ >>name ] [ >>mode ] bi* ] }
- [ drop first >>name dup trailing>> >>mode ]
- } case ;
-
-PRIVATE>
-
-GENERIC: irc-message>client-line ( irc-message -- string )
-
-M: irc-message irc-message>client-line ( irc-message -- string )
- [ command-string>> ]
- [ command-parameters>> " " sjoin ]
- [ trailing>> [ CHAR: : prefix ] [ "" ] if* ]
- tri 3array " " sjoin ;
-
-GENERIC: irc-message>server-line ( irc-message -- string )
-
-M: irc-message irc-message>server-line ( irc-message -- string )
- drop "not implemented yet" ;
-
-<PRIVATE
-
-! ======================================
-! Message parsing
-! ======================================
-
-: split-at-first ( seq separators -- before after )
- dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
-
-: remove-heading-: ( seq -- seq )
- ":" ?head drop ;
-
-: parse-name ( string -- string )
- remove-heading-: "!" split-at-first drop ;
-
-: split-prefix ( string -- string/f string )
- dup ":" head?
- [ remove-heading-: " " split1 ] [ f swap ] if ;
-
-: split-trailing ( string -- string string/f )
- ":" split1 ;
-
-: copy-message-in ( command irc-message -- command )
- {
- [ line>> >>line ]
- [ prefix>> >>prefix ]
- [ command>> >>command ]
- [ trailing>> >>trailing ]
- [ timestamp>> >>timestamp ]
- [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
- } cleave ;
-
-PRIVATE>
-
-UNION: sender-in-prefix privmsg join part quit kick mode nick ;
-GENERIC: irc-message-sender ( irc-message -- sender )
-M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
- prefix>> parse-name ;
-
-: string>irc-message ( string -- object )
- dup split-prefix split-trailing
- [ [ blank? ] trim " " split unclip swap ] dip
- now irc-message boa ;
-
-: irc-message>command ( irc-message -- command )
- [
- command>> {
- { "PING" [ ping ] }
- { "NOTICE" [ notice ] }
- { "001" [ logged-in ] }
- { "433" [ nick-in-use ] }
- { "353" [ names-reply ] }
- { "366" [ end-of-names ] }
- { "JOIN" [ join ] }
- { "PART" [ part ] }
- { "NICK" [ nick ] }
- { "PRIVMSG" [ privmsg ] }
- { "QUIT" [ quit ] }
- { "MODE" [ mode ] }
- { "KICK" [ kick ] }
- [ drop unhandled ]
- } case new
- ] keep copy-message-in ;
-
-: parse-irc-line ( string -- message )
- string>irc-message irc-message>command ;
+! connection
+IRC: pass "PASS" password ;
+IRC: nick "NICK" : nickname ;
+IRC: user "USER" user mode _ : realname ;
+IRC: oper "OPER" name password ;
+IRC: mode "MODE" name mode parameter ;
+IRC: service "SERVICE" nickname _ distribution type _ : info ;
+IRC: quit "QUIT" : comment ;
+IRC: squit "SQUIT" server : comment ;
+! channel operations
+IRC: join "JOIN" : channel ;
+IRC: part "PART" channel : comment ;
+IRC: topic "TOPIC" channel : topic ;
+IRC: names "NAMES" channel ;
+IRC: list "LIST" channel ;
+IRC: invite "INVITE" nickname channel ;
+IRC: kick "KICK" channel user : comment ;
+! chating
+IRC: privmsg "PRIVMSG" target : text ;
+IRC: notice "NOTICE" target : text ;
+! server queries
+IRC: motd "MOTD" target ;
+IRC: lusers "LUSERS" mask target ;
+IRC: version "VERSION" target ;
+IRC: stats "STATS" query target ;
+IRC: links "LINKS" server mask ;
+IRC: time "TIME" target ;
+IRC: connect "CONNECT" server port remote-server ;
+IRC: trace "TRACE" target ;
+IRC: admin "ADMIN" target ;
+IRC: info "INFO" target ;
+! service queries
+IRC: servlist "SERVLIST" mask type ;
+IRC: squery "SQUERY" service-name : text ;
+! user queries
+IRC: who "WHO" mask operator ;
+IRC: whois "WHOIS" target mask ;
+IRC: whowas "WHOWAS" nickname count target ;
+! misc
+IRC: kill "KILL" nickname : comment ;
+IRC: ping "PING" server1 server2 ;
+IRC: pong "PONG" server1 server2 ;
+IRC: error "ERROR" : message ;
+! numeric replies
+IRC: rpl-welcome "001" nickname : comment ;
+IRC: rpl-whois-user "311" nicnamek user host _ : real-name ;
+IRC: rpl-channel-modes "324" channel mode params ;
+IRC: rpl-notopic "331" channel : topic ;
+IRC: rpl-topic "332" channel : topic ;
+IRC: rpl-inviting "341" channel nickname ;
+IRC: rpl-names "353" nickname _ channel : nicks ;
+IRC: rpl-names-end "366" nickname channel : comment ;
+! error replies
+IRC: rpl-nickname-in-use "433" _ name ;
+IRC: rpl-nick-collision "436" nickname : comment ;
+
+M: rpl-names post-process-irc-message ( rpl-names -- )
+ [ [ blank? ] trim " " split ] change-nicks drop ;
+
+PREDICATE: channel-mode < mode name>> first "#&" member? ;
+PREDICATE: participant-mode < channel-mode parameter>> ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel fry splitting ascii calendar accessors combinators
+ arrays classes.tuple math.order words assocs
+ irc.messages.base sequences ;
+IN: irc.messages.parser
+
+<PRIVATE
+: split-at-first ( seq separators -- before after )
+ dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
+
+: split-trailing ( string -- string string/f ) ":" split1 ;
+: remove-heading-: ( seq -- seq ) ":" ?head drop ;
+
+: split-prefix ( string -- string/f string )
+ dup ":" head? [
+ remove-heading-: " " split1
+ ] [ f swap ] if ;
+
+: split-message ( string -- prefix command parameters trailing )
+ split-prefix split-trailing
+ [ [ blank? ] trim " " split unclip swap ] dip ;
+
+: sender ( irc-message -- sender )
+ prefix>> [ remove-heading-: "!" split-at-first drop ] [ f ] if* ;
+PRIVATE>
+
+: string>irc-message ( string -- irc-message )
+ dup split-message
+ [ [ irc>type new ] [ >>command ] bi ]
+ [ >>parameters ]
+ [ >>trailing ]
+ tri*
+ [ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri
+ now >>timestamp dup sender >>sender ;
--- /dev/null
+Basic parser for irc messages
--- /dev/null
+IRC message definitions
boot-cmd
] with-scope
] unit-test
+
+[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" } ] [
+ [
+ "winnt" target-os set
+ "x86.32" target-cpu set
+ boot-cmd
+ ] with-scope
+] unit-test
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays calendar combinators.short-circuit
-continuations debugger http.client io.directories io.files io.launcher
+continuations debugger io.directories io.files io.launcher
io.pathnames io.encodings.ascii kernel make mason.common mason.config
mason.platform mason.report mason.email namespaces sequences ;
IN: mason.child
: make-cmd ( -- args )
gnu-make platform 2array ;
-: dll-url ( -- url )
- "http://factorcode.org/dlls/"
- target-cpu get "x86.64" = [ "64/" append ] when ;
-
-: download-dlls ( -- )
- target-os get "winnt" = [
- dll-url "build-support/dlls.txt" ascii file-lines
- [ append download ] with each
- ] when ;
-
: make-vm ( -- )
"factor" [
- download-dlls
-
<process>
make-cmd >>command
"../compile-log" >>stdout
builds-factor-image "." copy-file-into
builds-factor-image "factor" copy-file-into ;
+: factor-vm ( -- string )
+ target-os get "winnt" = "./factor.com" "./factor" ? ;
+
: boot-cmd ( -- cmd )
- "./factor"
+ factor-vm
"-i=" boot-image-name append
"-no-user-init"
3array ;
try-process
] with-directory ;
-: test-cmd ( -- cmd ) { "./factor" "-run=mason.test" } ;
+: test-cmd ( -- cmd ) factor-vm "-run=mason.test" 2array ;
: test ( -- )
"factor" [
build-dir [
compress-image
compress-test-log
- "factor" delete-tree
+ "factor" really-delete-tree
] with-directory
] unless ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences splitting system accessors
math.functions make io io.files io.pathnames io.directories
-io.launcher io.encodings.utf8 prettyprint
+io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
combinators.short-circuit parser combinators calendar
-calendar.format arrays mason.config locals ;
+calendar.format arrays mason.config locals system ;
IN: mason.common
+HOOK: really-delete-tree os ( path -- )
+
+M: windows really-delete-tree
+ #! Workaround: Cygwin GIT creates read-only files for
+ #! some reason.
+ [ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-process ]
+ [ delete-tree ]
+ bi ;
+
+M: unix really-delete-tree delete-tree ;
+
: short-running-process ( command -- )
#! Give network operations at most 15 minutes to complete.
<process>
"-fs" "HFS+"
"-volname" "factor" }
archive-name suffix try-process
- "dmg-root" delete-tree ;
+ "dmg-root" really-delete-tree ;
: make-unix-archive ( -- )
[ "tar" , "-cvzf" , archive-name , "factor" , ] { } make try-process ;
append ;
: remove-common-files ( -- )
- common-files [ delete-tree ] each ;
+ common-files [ really-delete-tree ] each ;
: remove-factor-app ( -- )
target-os get "macosx" =
- [ "Factor.app" delete-tree ] unless ;
+ [ "Factor.app" really-delete-tree ] unless ;
: tidy ( -- )
"factor" [ remove-factor-app remove-common-files ] with-directory ;
compiler.errors generic help.html help.lint io.directories
io.encodings.utf8 io.files kernel mason.common math namespaces
prettyprint sequences sets sorting tools.test tools.time
-tools.vocabs words ;
+tools.vocabs words system io ;
IN: mason.test
: do-load ( -- )
: benchmark-ms ( quot -- ms )
benchmark 1000 /i ; inline
+: check-boot-image ( -- )
+ "" to-refresh drop 2dup [ empty? not ] either?
+ [
+ "Boot image is out of date. Changed vocabs:" print
+ append prune [ print ] each
+ flush
+ 1 exit
+ ] [ 2drop ] if ;
+
: do-all ( -- )
".." [
bootstrap-time get boot-time-file to-file
+ check-boot-image
[ do-load do-compile-errors ] benchmark-ms load-time-file to-file
[ generate-help ] benchmark-ms html-help-time-file to-file
[ do-tests ] benchmark-ms test-time-file to-file
#! gamma(x) = integral 0..inf [ t^(x-1) exp(-t) ] dt
#! gamma(n+1) = n! for n > 0
dup { [ 0.0 <= ] [ 1.0 mod zero? ] } 1&& [
- drop 1./0.
+ drop 1/0.
] [
[ abs gamma-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if
] if ;
#! gammaln(x) is an alternative when gamma(x)'s range
#! varies too widely
dup 0 < [
- drop 1./0.
+ drop 1/0.
] [
[ abs gammaln-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if
] if ;
{ deploy-word-props? f }
{ deploy-c-types? f }
{ "stop-after-last-window?" t }
- { deploy-name "Catalyst Talk" }
+ { deploy-name "Minnesota Talk" }
}
-Slides for a talk at Ruby.mn, Minneapolis MN, January 2008
+Slides for a talk at Ruby.mn, Minneapolis, MN, January 2008
--- /dev/null
+USING: help.syntax help.markup kernel math classes classes.tuple\r
+calendar models ;\r
+IN: models.history\r
+\r
+HELP: history\r
+{ $class-description "History models record a timeline of previous values on calls to " { $link add-history } ", and can travel back and forth on the timeline with " { $link go-back } " and " { $link go-forward } ". History models are constructed by " { $link <history> } "." } ;\r
+\r
+HELP: <history>\r
+{ $values { "value" object } { "history" "a new " { $link history } } }\r
+{ $description "Creates a new history model with an initial value." } ;\r
+\r
+{ <history> add-history go-back go-forward } related-words\r
+\r
+HELP: go-back\r
+{ $values { "history" history } }\r
+{ $description "Restores the previous value and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;\r
+\r
+HELP: go-forward\r
+{ $values { "history" history } }\r
+{ $description "Restores the value set prior to the last call to " { $link go-back } " and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;\r
+\r
+HELP: add-history\r
+{ $values { "history" history } }\r
+{ $description "Adds the current value to the history." } ;\r
+\r
+ARTICLE: "models-history" "History models"\r
+"History models record previous values."\r
+{ $subsection history }\r
+{ $subsection <history> }\r
+"Recording history:"\r
+{ $subsection add-history }\r
+"Navigating the history:"\r
+{ $subsection go-back }\r
+{ $subsection go-forward } ;\r
+\r
+ABOUT: "models-history"\r
--- /dev/null
+USING: arrays generic kernel math models namespaces sequences assocs\r
+tools.test models.history accessors ;\r
+IN: models.history.tests\r
+\r
+f <history> "history" set\r
+\r
+"history" get add-history\r
+\r
+[ t ] [ "history" get back>> empty? ] unit-test\r
+[ t ] [ "history" get forward>> empty? ] unit-test\r
+\r
+"history" get add-history\r
+3 "history" get set-model\r
+\r
+[ t ] [ "history" get back>> empty? ] unit-test\r
+[ t ] [ "history" get forward>> empty? ] unit-test\r
+\r
+"history" get add-history\r
+4 "history" get set-model\r
+\r
+[ f ] [ "history" get back>> empty? ] unit-test\r
+[ t ] [ "history" get forward>> empty? ] unit-test\r
+\r
+"history" get go-back\r
+\r
+[ 3 ] [ "history" get value>> ] unit-test\r
+\r
+[ t ] [ "history" get back>> empty? ] unit-test\r
+[ f ] [ "history" get forward>> empty? ] unit-test\r
+\r
+"history" get go-forward\r
+\r
+[ 4 ] [ "history" get value>> ] unit-test\r
+\r
+[ f ] [ "history" get back>> empty? ] unit-test\r
+[ t ] [ "history" get forward>> empty? ] unit-test\r
+\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors kernel models sequences ;\r
+IN: models.history\r
+\r
+TUPLE: history < model back forward ;\r
+\r
+: reset-history ( history -- history )\r
+ V{ } clone >>back\r
+ V{ } clone >>forward ; inline\r
+\r
+: <history> ( value -- history )\r
+ history new-model\r
+ reset-history ;\r
+\r
+: (add-history) ( history to -- )\r
+ swap value>> dup [ swap push ] [ 2drop ] if ;\r
+\r
+: go-back/forward ( history to from -- )\r
+ [ 2drop ]\r
+ [ [ dupd (add-history) ] dip pop swap set-model ] if-empty ;\r
+\r
+: go-back ( history -- )\r
+ dup [ forward>> ] [ back>> ] bi go-back/forward ;\r
+\r
+: go-forward ( history -- )\r
+ dup [ back>> ] [ forward>> ] bi go-back/forward ;\r
+\r
+: add-history ( history -- )\r
+ dup forward>> delete-all\r
+ dup back>> (add-history) ;\r
--- /dev/null
+History models remember prior values
--- /dev/null
+extensions
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2005 Alex Chapman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.libraries alien.syntax kernel sequences words system
+combinators ;
+IN: opengl.glu
+
+os {
+ { [ dup macosx? ] [ drop ] }
+ { [ dup windows? ] [ drop ] }
+ { [ dup unix? ] [ drop "glu" "libGLU.so.1" "cdecl" add-library ] }
+} cond
+
+LIBRARY: glu
+
+! These are defined as structs in glu.h, but we only ever use pointers to them
+TYPEDEF: void* GLUnurbs*
+TYPEDEF: void* GLUquadric*
+TYPEDEF: void* GLUtesselator*
+TYPEDEF: void* GLubyte*
+TYPEDEF: void* GLUfuncptr
+
+! StringName
+CONSTANT: GLU_VERSION 100800
+CONSTANT: GLU_EXTENSIONS 100801
+
+! ErrorCode
+CONSTANT: GLU_INVALID_ENUM 100900
+CONSTANT: GLU_INVALID_VALUE 100901
+CONSTANT: GLU_OUT_OF_MEMORY 100902
+CONSTANT: GLU_INCOMPATIBLE_GL_VERSION 100903
+CONSTANT: GLU_INVALID_OPERATION 100904
+
+! NurbsDisplay
+CONSTANT: GLU_OUTLINE_POLYGON 100240
+CONSTANT: GLU_OUTLINE_PATCH 100241
+
+! NurbsCallback
+CONSTANT: GLU_NURBS_ERROR 100103
+CONSTANT: GLU_ERROR 100103
+CONSTANT: GLU_NURBS_BEGIN 100164
+CONSTANT: GLU_NURBS_BEGIN_EXT 100164
+CONSTANT: GLU_NURBS_VERTEX 100165
+CONSTANT: GLU_NURBS_VERTEX_EXT 100165
+CONSTANT: GLU_NURBS_NORMAL 100166
+CONSTANT: GLU_NURBS_NORMAL_EXT 100166
+CONSTANT: GLU_NURBS_COLOR 100167
+CONSTANT: GLU_NURBS_COLOR_EXT 100167
+CONSTANT: GLU_NURBS_TEXTURE_COORD 100168
+CONSTANT: GLU_NURBS_TEX_COORD_EXT 100168
+CONSTANT: GLU_NURBS_END 100169
+CONSTANT: GLU_NURBS_END_EXT 100169
+CONSTANT: GLU_NURBS_BEGIN_DATA 100170
+CONSTANT: GLU_NURBS_BEGIN_DATA_EXT 100170
+CONSTANT: GLU_NURBS_VERTEX_DATA 100171
+CONSTANT: GLU_NURBS_VERTEX_DATA_EXT 100171
+CONSTANT: GLU_NURBS_NORMAL_DATA 100172
+CONSTANT: GLU_NURBS_NORMAL_DATA_EXT 100172
+CONSTANT: GLU_NURBS_COLOR_DATA 100173
+CONSTANT: GLU_NURBS_COLOR_DATA_EXT 100173
+CONSTANT: GLU_NURBS_TEXTURE_COORD_DATA 100174
+CONSTANT: GLU_NURBS_TEX_COORD_DATA_EXT 100174
+CONSTANT: GLU_NURBS_END_DATA 100175
+CONSTANT: GLU_NURBS_END_DATA_EXT 100175
+
+! NurbsError
+CONSTANT: GLU_NURBS_ERROR1 100251
+CONSTANT: GLU_NURBS_ERROR2 100252
+CONSTANT: GLU_NURBS_ERROR3 100253
+CONSTANT: GLU_NURBS_ERROR4 100254
+CONSTANT: GLU_NURBS_ERROR5 100255
+CONSTANT: GLU_NURBS_ERROR6 100256
+CONSTANT: GLU_NURBS_ERROR7 100257
+CONSTANT: GLU_NURBS_ERROR8 100258
+CONSTANT: GLU_NURBS_ERROR9 100259
+CONSTANT: GLU_NURBS_ERROR10 100260
+CONSTANT: GLU_NURBS_ERROR11 100261
+CONSTANT: GLU_NURBS_ERROR12 100262
+CONSTANT: GLU_NURBS_ERROR13 100263
+CONSTANT: GLU_NURBS_ERROR14 100264
+CONSTANT: GLU_NURBS_ERROR15 100265
+CONSTANT: GLU_NURBS_ERROR16 100266
+CONSTANT: GLU_NURBS_ERROR17 100267
+CONSTANT: GLU_NURBS_ERROR18 100268
+CONSTANT: GLU_NURBS_ERROR19 100269
+CONSTANT: GLU_NURBS_ERROR20 100270
+CONSTANT: GLU_NURBS_ERROR21 100271
+CONSTANT: GLU_NURBS_ERROR22 100272
+CONSTANT: GLU_NURBS_ERROR23 100273
+CONSTANT: GLU_NURBS_ERROR24 100274
+CONSTANT: GLU_NURBS_ERROR25 100275
+CONSTANT: GLU_NURBS_ERROR26 100276
+CONSTANT: GLU_NURBS_ERROR27 100277
+CONSTANT: GLU_NURBS_ERROR28 100278
+CONSTANT: GLU_NURBS_ERROR29 100279
+CONSTANT: GLU_NURBS_ERROR30 100280
+CONSTANT: GLU_NURBS_ERROR31 100281
+CONSTANT: GLU_NURBS_ERROR32 100282
+CONSTANT: GLU_NURBS_ERROR33 100283
+CONSTANT: GLU_NURBS_ERROR34 100284
+CONSTANT: GLU_NURBS_ERROR35 100285
+CONSTANT: GLU_NURBS_ERROR36 100286
+CONSTANT: GLU_NURBS_ERROR37 100287
+
+! NurbsProperty
+CONSTANT: GLU_AUTO_LOAD_MATRIX 100200
+CONSTANT: GLU_CULLING 100201
+CONSTANT: GLU_SAMPLING_TOLERANCE 100203
+CONSTANT: GLU_DISPLAY_MODE 100204
+CONSTANT: GLU_PARAMETRIC_TOLERANCE 100202
+CONSTANT: GLU_SAMPLING_METHOD 100205
+CONSTANT: GLU_U_STEP 100206
+CONSTANT: GLU_V_STEP 100207
+CONSTANT: GLU_NURBS_MODE 100160
+CONSTANT: GLU_NURBS_MODE_EXT 100160
+CONSTANT: GLU_NURBS_TESSELLATOR 100161
+CONSTANT: GLU_NURBS_TESSELLATOR_EXT 100161
+CONSTANT: GLU_NURBS_RENDERER 100162
+CONSTANT: GLU_NURBS_RENDERER_EXT 100162
+
+! NurbsSampling
+CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR 100208
+CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR_EXT 100208
+CONSTANT: GLU_OBJECT_PATH_LENGTH 100209
+CONSTANT: GLU_OBJECT_PATH_LENGTH_EXT 100209
+CONSTANT: GLU_PATH_LENGTH 100215
+CONSTANT: GLU_PARAMETRIC_ERROR 100216
+CONSTANT: GLU_DOMAIN_DISTANCE 100217
+
+! NurbsTrim
+CONSTANT: GLU_MAP1_TRIM_2 100210
+CONSTANT: GLU_MAP1_TRIM_3 100211
+
+! QuadricDrawStyle
+CONSTANT: GLU_POINT 100010
+CONSTANT: GLU_LINE 100011
+CONSTANT: GLU_FILL 100012
+CONSTANT: GLU_SILHOUETTE 100013
+
+! QuadricNormal
+CONSTANT: GLU_SMOOTH 100000
+CONSTANT: GLU_FLAT 100001
+CONSTANT: GLU_NONE 100002
+
+! QuadricOrientation
+CONSTANT: GLU_OUTSIDE 100020
+CONSTANT: GLU_INSIDE 100021
+
+! TessCallback
+CONSTANT: GLU_TESS_BEGIN 100100
+CONSTANT: GLU_BEGIN 100100
+CONSTANT: GLU_TESS_VERTEX 100101
+CONSTANT: GLU_VERTEX 100101
+CONSTANT: GLU_TESS_END 100102
+CONSTANT: GLU_END 100102
+CONSTANT: GLU_TESS_ERROR 100103
+CONSTANT: GLU_TESS_EDGE_FLAG 100104
+CONSTANT: GLU_EDGE_FLAG 100104
+CONSTANT: GLU_TESS_COMBINE 100105
+CONSTANT: GLU_TESS_BEGIN_DATA 100106
+CONSTANT: GLU_TESS_VERTEX_DATA 100107
+CONSTANT: GLU_TESS_END_DATA 100108
+CONSTANT: GLU_TESS_ERROR_DATA 100109
+CONSTANT: GLU_TESS_EDGE_FLAG_DATA 100110
+CONSTANT: GLU_TESS_COMBINE_DATA 100111
+
+! TessContour
+CONSTANT: GLU_CW 100120
+CONSTANT: GLU_CCW 100121
+CONSTANT: GLU_INTERIOR 100122
+CONSTANT: GLU_EXTERIOR 100123
+CONSTANT: GLU_UNKNOWN 100124
+
+! TessProperty
+CONSTANT: GLU_TESS_WINDING_RULE 100140
+CONSTANT: GLU_TESS_BOUNDARY_ONLY 100141
+CONSTANT: GLU_TESS_TOLERANCE 100142
+
+! TessError
+CONSTANT: GLU_TESS_ERROR1 100151
+CONSTANT: GLU_TESS_ERROR2 100152
+CONSTANT: GLU_TESS_ERROR3 100153
+CONSTANT: GLU_TESS_ERROR4 100154
+CONSTANT: GLU_TESS_ERROR5 100155
+CONSTANT: GLU_TESS_ERROR6 100156
+CONSTANT: GLU_TESS_ERROR7 100157
+CONSTANT: GLU_TESS_ERROR8 100158
+CONSTANT: GLU_TESS_MISSING_BEGIN_POLYGON 100151
+CONSTANT: GLU_TESS_MISSING_BEGIN_CONTOUR 100152
+CONSTANT: GLU_TESS_MISSING_END_POLYGON 100153
+CONSTANT: GLU_TESS_MISSING_END_CONTOUR 100154
+CONSTANT: GLU_TESS_COORD_TOO_LARGE 100155
+CONSTANT: GLU_TESS_NEED_COMBINE_CALLBACK 100156
+
+! TessWinding
+CONSTANT: GLU_TESS_WINDING_ODD 100130
+CONSTANT: GLU_TESS_WINDING_NONZERO 100131
+CONSTANT: GLU_TESS_WINDING_POSITIVE 100132
+CONSTANT: GLU_TESS_WINDING_NEGATIVE 100133
+CONSTANT: GLU_TESS_WINDING_ABS_GEQ_TWO 100134
+
+LIBRARY: glu
+
+FUNCTION: void gluBeginCurve ( GLUnurbs* nurb ) ;
+FUNCTION: void gluBeginPolygon ( GLUtesselator* tess ) ;
+FUNCTION: void gluBeginSurface ( GLUnurbs* nurb ) ;
+FUNCTION: void gluBeginTrim ( GLUnurbs* nurb ) ;
+
+FUNCTION: void gluCylinder ( GLUquadric* quad, GLdouble base, GLdouble top, GLdouble height, GLint slices, GLint stacks ) ;
+FUNCTION: void gluDeleteNurbsRenderer ( GLUnurbs* nurb ) ;
+FUNCTION: void gluDeleteQuadric ( GLUquadric* quad ) ;
+FUNCTION: void gluDeleteTess ( GLUtesselator* tess ) ;
+FUNCTION: void gluDisk ( GLUquadric* quad, GLdouble inner, GLdouble outer, GLint slices, GLint loops ) ;
+FUNCTION: void gluEndCurve ( GLUnurbs* nurb ) ;
+FUNCTION: void gluEndPolygon ( GLUtesselator* tess ) ;
+FUNCTION: void gluEndSurface ( GLUnurbs* nurb ) ;
+FUNCTION: void gluEndTrim ( GLUnurbs* nurb ) ;
+FUNCTION: char* gluErrorString ( GLenum error ) ;
+FUNCTION: void gluGetNurbsProperty ( GLUnurbs* nurb, GLenum property, GLfloat* data ) ;
+FUNCTION: char* gluGetString ( GLenum name ) ;
+FUNCTION: void gluGetTessProperty ( GLUtesselator* tess, GLenum which, GLdouble* data ) ;
+FUNCTION: void gluLoadSamplingMatrices ( GLUnurbs* nurb, GLfloat* model, GLfloat* perspective, GLint* view ) ;
+FUNCTION: void gluLookAt ( GLdouble eyeX, GLdouble eyeY, GLdouble eyeZ, GLdouble centerX, GLdouble centerY, GLdouble centerZ, GLdouble upX, GLdouble upY, GLdouble upZ ) ;
+FUNCTION: GLUnurbs* gluNewNurbsRenderer ( ) ;
+FUNCTION: GLUquadric* gluNewQuadric ( ) ;
+FUNCTION: GLUtesselator* gluNewTess ( ) ;
+FUNCTION: void gluNextContour ( GLUtesselator* tess, GLenum type ) ;
+FUNCTION: void gluNurbsCallback ( GLUnurbs* nurb, GLenum which, GLUfuncptr CallBackFunc ) ;
+! FUNCTION: void gluNurbsCallbackData ( GLUnurbs* nurb, GLvoid* userData ) ;
+! FUNCTION: void gluNurbsCallbackDataEXT ( GLUnurbs* nurb, GLvoid* userData ) ;
+FUNCTION: void gluNurbsCurve ( GLUnurbs* nurb, GLint knotCount, GLfloat *knots, GLint stride, GLfloat *control, GLint order, GLenum type ) ;
+FUNCTION: void gluNurbsProperty ( GLUnurbs* nurb, GLenum property, GLfloat value ) ;
+FUNCTION: void gluNurbsSurface ( GLUnurbs* nurb, GLint sKnotCount, GLfloat* sKnots, GLint tKnotCount, GLfloat* tKnots, GLint sStride, GLint tStride, GLfloat* control, GLint sOrder, GLint tOrder, GLenum type ) ;
+FUNCTION: void gluOrtho2D ( GLdouble left, GLdouble right, GLdouble bottom, GLdouble top ) ;
+FUNCTION: void gluPartialDisk ( GLUquadric* quad, GLdouble inner, GLdouble outer, GLint slices, GLint loops, GLdouble start, GLdouble sweep ) ;
+FUNCTION: void gluPerspective ( GLdouble fovy, GLdouble aspect, GLdouble zNear, GLdouble zFar ) ;
+FUNCTION: void gluPickMatrix ( GLdouble x, GLdouble y, GLdouble delX, GLdouble delY, GLint* viewport ) ;
+FUNCTION: GLint gluProject ( GLdouble objX, GLdouble objY, GLdouble objZ, GLdouble* model, GLdouble* proj, GLint* view, GLdouble* winX, GLdouble* winY, GLdouble* winZ ) ;
+FUNCTION: void gluPwlCurve ( GLUnurbs* nurb, GLint count, GLfloat* data, GLint stride, GLenum type ) ;
+FUNCTION: void gluQuadricCallback ( GLUquadric* quad, GLenum which, GLUfuncptr CallBackFunc ) ;
+FUNCTION: void gluQuadricDrawStyle ( GLUquadric* quad, GLenum draw ) ;
+FUNCTION: void gluQuadricNormals ( GLUquadric* quad, GLenum normal ) ;
+FUNCTION: void gluQuadricOrientation ( GLUquadric* quad, GLenum orientation ) ;
+FUNCTION: void gluQuadricTexture ( GLUquadric* quad, GLboolean texture ) ;
+FUNCTION: GLint gluScaleImage ( GLenum format, GLsizei wIn, GLsizei hIn, GLenum typeIn, void* dataIn, GLsizei wOut, GLsizei hOut, GLenum typeOut, GLvoid* dataOut ) ;
+FUNCTION: void gluSphere ( GLUquadric* quad, GLdouble radius, GLint slices, GLint stacks ) ;
+FUNCTION: void gluTessBeginContour ( GLUtesselator* tess ) ;
+FUNCTION: void gluTessBeginPolygon ( GLUtesselator* tess, GLvoid* data ) ;
+FUNCTION: void gluTessCallback ( GLUtesselator* tess, GLenum which, GLUfuncptr CallBackFunc ) ;
+FUNCTION: void gluTessEndContour ( GLUtesselator* tess ) ;
+FUNCTION: void gluTessEndPolygon ( GLUtesselator* tess ) ;
+FUNCTION: void gluTessNormal ( GLUtesselator* tess, GLdouble valueX, GLdouble valueY, GLdouble valueZ ) ;
+FUNCTION: void gluTessProperty ( GLUtesselator* tess, GLenum which, GLdouble data ) ;
+FUNCTION: void gluTessVertex ( GLUtesselator* tess, GLdouble* location, GLvoid* data ) ;
+FUNCTION: GLint gluUnProject ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble* model, GLdouble* proj, GLint* view, GLdouble* objX, GLdouble* objY, GLdouble* objZ ) ;
+
+! Not present on Windows
+! FUNCTION: GLint gluBuild1DMipmapLevels ( GLenum target, GLint internalFormat, GLsizei width, GLenum format, GLenum type, GLint level, GLint base, GLint max, void* data ) ;
+! FUNCTION: GLint gluBuild1DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLenum format, GLenum type, void* data ) ;
+! FUNCTION: GLint gluBuild2DMipmapLevels ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLenum format, GLenum type, GLint level, GLint base, GLint max, void* data ) ;
+! FUNCTION: GLint gluBuild2DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLenum format, GLenum type, void* data ) ;
+! FUNCTION: GLint gluBuild3DMipmapLevels ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, GLint level, GLint base, GLint max, void* data ) ;
+! FUNCTION: GLint gluBuild3DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, void* data ) ;
+! FUNCTION: GLboolean gluCheckExtension ( GLubyte* extName, GLubyte* extString ) ;
+! FUNCTION: GLint gluUnProject4 ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble clipW, GLdouble* model, GLdouble* proj, GLint* view, GLdouble nearVal, GLdouble farVal, GLdouble* objX, GLdouble* objY, GLdouble* objZ, GLdouble* objW ) ;
+
+: gl-look-at ( eye focus up -- )
+ [ first3 ] tri@ gluLookAt ;
\ No newline at end of file
--- /dev/null
+OpenGL binding - libGLU
-reflection
\ No newline at end of file
+extensions
+reflection
#! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
-EBNF: pl0
+EBNF: pl0
-block = { "CONST" ident "=" number { "," ident "=" number }* ";" }?
- { "VAR" ident { "," ident }* ";" }?
- { "PROCEDURE" ident ";" { block ";" }? }* statement
-statement = { ident ":=" expression
- | "CALL" ident
- | "BEGIN" statement { ";" statement }* "END"
- | "IF" condition "THEN" statement
- | "WHILE" condition "DO" statement }?
+block = { "CONST" ident "=" number { "," ident "=" number }* ";" }?
+ { "VAR" ident { "," ident }* ";" }?
+ { "PROCEDURE" ident ";" { block ";" }? }* statement
+statement = { ident ":=" expression
+ | "CALL" ident
+ | "BEGIN" statement { ";" statement }* "END"
+ | "IF" condition "THEN" statement
+ | "WHILE" condition "DO" statement }?
condition = { "ODD" expression }
| { expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression }
-expression = {"+" | "-"}? term { {"+" | "-"} term }*
-term = factor { {"*" | "/"} factor }*
+expression = {"+" | "-"}? term { {"+" | "-"} term }*
+term = factor { {"*" | "/"} factor }*
factor = ident | number | "(" expression ")"
ident = (([a-zA-Z])+) => [[ >string ]]
digit = ([0-9]) => [[ digit> ]]
--- /dev/null
+! Copyright (c) 2009 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+IN: poker.arrays
+
+! This is a lookup table for all flush hands. A zero means that specific
+! combination is not possible with this type of hand.
+CONSTANT: flushes-table
+{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 9 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 1599 0 0 0 0 0 0 0 1598 0 0 0 1597 0 1596 8 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 1595 0 0 0 0 0 0 0 1594 0 0 0 1593 0 1592 1591 0 0 0 0 0 0 0 0 1590
+0 0 0 1589 0 1588 1587 0 0 0 0 1586 0 1585 1584 0 0 1583 1582 0 7 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 1581 0 0 0 0 0 0 0 1580 0 0 0 1579 0 1578 1577 0 0 0 0 0
+0 0 0 1576 0 0 0 1575 0 1574 1573 0 0 0 0 1572 0 1571 1570 0 0 1569 1568 0 1567
+0 0 0 0 0 0 0 0 0 0 1566 0 0 0 1565 0 1564 1563 0 0 0 0 1562 0 1561 1560 0 0
+1559 1558 0 1557 0 0 0 0 0 0 1556 0 1555 1554 0 0 1553 1552 0 1551 0 0 0 0 1550
+1549 0 1548 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1547 0 0 0 0 0
+0 0 1546 0 0 0 1545 0 1544 1543 0 0 0 0 0 0 0 0 1542 0 0 0 1541 0 1540 1539 0 0
+0 0 1538 0 1537 1536 0 0 1535 1534 0 1533 0 0 0 0 0 0 0 0 0 0 1532 0 0 0 1531 0
+1530 1529 0 0 0 0 1528 0 1527 1526 0 0 1525 1524 0 1523 0 0 0 0 0 0 1522 0 1521
+1520 0 0 1519 1518 0 1517 0 0 0 0 1516 1515 0 1514 0 0 0 1513 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 1512 0 0 0 1511 0 1510 1509 0 0 0 0 1508 0 1507 1506 0 0 1505 1504 0
+1503 0 0 0 0 0 0 1502 0 1501 1500 0 0 1499 1498 0 1497 0 0 0 0 1496 1495 0 1494
+0 0 0 1493 0 0 0 0 0 0 0 0 0 0 1492 0 1491 1490 0 0 1489 1488 0 1487 0 0 0 0
+1486 1485 0 1484 0 0 0 1483 0 0 0 0 0 0 0 0 1482 1481 0 1480 0 0 0 1479 0 0 0 0
+0 0 0 5 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1478 0 0 0
+0 0 0 0 1477 0 0 0 1476 0 1475 1474 0 0 0 0 0 0 0 0 1473 0 0 0 1472 0 1471 1470
+0 0 0 0 1469 0 1468 1467 0 0 1466 1465 0 1464 0 0 0 0 0 0 0 0 0 0 1463 0 0 0
+1462 0 1461 1460 0 0 0 0 1459 0 1458 1457 0 0 1456 1455 0 1454 0 0 0 0 0 0 1453
+0 1452 1451 0 0 1450 1449 0 1448 0 0 0 0 1447 1446 0 1445 0 0 0 1444 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 1443 0 0 0 1442 0 1441 1440 0 0 0 0 1439 0 1438 1437 0 0 1436
+1435 0 1434 0 0 0 0 0 0 1433 0 1432 1431 0 0 1430 1429 0 1428 0 0 0 0 1427 1426
+0 1425 0 0 0 1424 0 0 0 0 0 0 0 0 0 0 1423 0 1422 1421 0 0 1420 1419 0 1418 0 0
+0 0 1417 1416 0 1415 0 0 0 1414 0 0 0 0 0 0 0 0 1413 1412 0 1411 0 0 0 1410 0 0
+0 0 0 0 0 1409 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1408 0 0 0 1407 0
+1406 1405 0 0 0 0 1404 0 1403 1402 0 0 1401 1400 0 1399 0 0 0 0 0 0 1398 0 1397
+1396 0 0 1395 1394 0 1393 0 0 0 0 1392 1391 0 1390 0 0 0 1389 0 0 0 0 0 0 0 0 0
+0 1388 0 1387 1386 0 0 1385 1384 0 1383 0 0 0 0 1382 1381 0 1380 0 0 0 1379 0 0
+0 0 0 0 0 0 1378 1377 0 1376 0 0 0 1375 0 0 0 0 0 0 0 1374 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 1373 0 1372 1371 0 0 1370 1369 0 1368 0 0 0 0 1367 1366 0 1365
+0 0 0 1364 0 0 0 0 0 0 0 0 1363 1362 0 1361 0 0 0 1360 0 0 0 0 0 0 0 1359 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 1358 1357 0 1356 0 0 0 1355 0 0 0 0 0 0 0 1354 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1353 0 0 0 0 0 0 0 1352 0 0 0 1351 0 1350
+1349 0 0 0 0 0 0 0 0 1348 0 0 0 1347 0 1346 1345 0 0 0 0 1344 0 1343 1342 0 0
+1341 1340 0 1339 0 0 0 0 0 0 0 0 0 0 1338 0 0 0 1337 0 1336 1335 0 0 0 0 1334 0
+1333 1332 0 0 1331 1330 0 1329 0 0 0 0 0 0 1328 0 1327 1326 0 0 1325 1324 0
+1323 0 0 0 0 1322 1321 0 1320 0 0 0 1319 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1318 0 0 0
+1317 0 1316 1315 0 0 0 0 1314 0 1313 1312 0 0 1311 1310 0 1309 0 0 0 0 0 0 1308
+0 1307 1306 0 0 1305 1304 0 1303 0 0 0 0 1302 1301 0 1300 0 0 0 1299 0 0 0 0 0
+0 0 0 0 0 1298 0 1297 1296 0 0 1295 1294 0 1293 0 0 0 0 1292 1291 0 1290 0 0 0
+1289 0 0 0 0 0 0 0 0 1288 1287 0 1286 0 0 0 1285 0 0 0 0 0 0 0 1284 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1283 0 0 0 1282 0 1281 1280 0 0 0 0 1279 0 1278
+1277 0 0 1276 1275 0 1274 0 0 0 0 0 0 1273 0 1272 1271 0 0 1270 1269 0 1268 0 0
+0 0 1267 1266 0 1265 0 0 0 1264 0 0 0 0 0 0 0 0 0 0 1263 0 1262 1261 0 0 1260
+1259 0 1258 0 0 0 0 1257 1256 0 1255 0 0 0 1254 0 0 0 0 0 0 0 0 1253 1252 0
+1251 0 0 0 1250 0 0 0 0 0 0 0 1249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1248 0
+1247 1246 0 0 1245 1244 0 1243 0 0 0 0 1242 1241 0 1240 0 0 0 1239 0 0 0 0 0 0
+0 0 1238 1237 0 1236 0 0 0 1235 0 0 0 0 0 0 0 1234 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 1233 1232 0 1231 0 0 0 1230 0 0 0 0 0 0 0 1229 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 1228 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 1227 0 0 0 1226 0 1225 1224 0 0 0 0 1223 0 1222 1221 0 0 1220 1219 0 1218 0
+0 0 0 0 0 1217 0 1216 1215 0 0 1214 1213 0 1212 0 0 0 0 1211 1210 0 1209 0 0 0
+1208 0 0 0 0 0 0 0 0 0 0 1207 0 1206 1205 0 0 1204 1203 0 1202 0 0 0 0 1201
+1200 0 1199 0 0 0 1198 0 0 0 0 0 0 0 0 1197 1196 0 1195 0 0 0 1194 0 0 0 0 0 0
+0 1193 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1192 0 1191 1190 0 0 1189 1188 0
+1187 0 0 0 0 1186 1185 0 1184 0 0 0 1183 0 0 0 0 0 0 0 0 1182 1181 0 1180 0 0 0
+1179 0 0 0 0 0 0 0 1178 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1177 1176 0 1175 0 0 0
+1174 0 0 0 0 0 0 0 1173 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1172 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1171 0 1170 1169 0 0 1168 1167
+0 1166 0 0 0 0 1165 1164 0 1163 0 0 0 1162 0 0 0 0 0 0 0 0 1161 1160 0 1159 0 0
+0 1158 0 0 0 0 0 0 0 1157 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1156 1155 0 1154 0 0
+0 1153 0 0 0 0 0 0 0 1152 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1151 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1150 1149 0 1148 0 0 0 1147 0 0 0
+0 0 0 0 1146 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1145 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 1144 0 0 0 0 0 0 0 1143 0 0 0 1142 0 1141 1140 0 0
+0 0 0 0 0 0 1139 0 0 0 1138 0 1137 1136 0 0 0 0 1135 0 1134 1133 0 0 1132 1131
+0 1130 0 0 0 0 0 0 0 0 0 0 1129 0 0 0 1128 0 1127 1126 0 0 0 0 1125 0 1124 1123
+0 0 1122 1121 0 1120 0 0 0 0 0 0 1119 0 1118 1117 0 0 1116 1115 0 1114 0 0 0 0
+1113 1112 0 1111 0 0 0 1110 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1109 0 0 0 1108 0 1107
+1106 0 0 0 0 1105 0 1104 1103 0 0 1102 1101 0 1100 0 0 0 0 0 0 1099 0 1098 1097
+0 0 1096 1095 0 1094 0 0 0 0 1093 1092 0 1091 0 0 0 1090 0 0 0 0 0 0 0 0 0 0
+1089 0 1088 1087 0 0 1086 1085 0 1084 0 0 0 0 1083 1082 0 1081 0 0 0 1080 0 0 0
+0 0 0 0 0 1079 1078 0 1077 0 0 0 1076 0 0 0 0 0 0 0 1075 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 1074 0 0 0 1073 0 1072 1071 0 0 0 0 1070 0 1069 1068 0 0
+1067 1066 0 1065 0 0 0 0 0 0 1064 0 1063 1062 0 0 1061 1060 0 1059 0 0 0 0 1058
+1057 0 1056 0 0 0 1055 0 0 0 0 0 0 0 0 0 0 1054 0 1053 1052 0 0 1051 1050 0
+1049 0 0 0 0 1048 1047 0 1046 0 0 0 1045 0 0 0 0 0 0 0 0 1044 1043 0 1042 0 0 0
+1041 0 0 0 0 0 0 0 1040 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1039 0 1038 1037 0
+0 1036 1035 0 1034 0 0 0 0 1033 1032 0 1031 0 0 0 1030 0 0 0 0 0 0 0 0 1029
+1028 0 1027 0 0 0 1026 0 0 0 0 0 0 0 1025 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1024
+1023 0 1022 0 0 0 1021 0 0 0 0 0 0 0 1020 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1019 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1018
+0 0 0 1017 0 1016 1015 0 0 0 0 1014 0 1013 1012 0 0 1011 1010 0 1009 0 0 0 0 0
+0 1008 0 1007 1006 0 0 1005 1004 0 1003 0 0 0 0 1002 1001 0 1000 0 0 0 999 0 0
+0 0 0 0 0 0 0 0 998 0 997 996 0 0 995 994 0 993 0 0 0 0 992 991 0 990 0 0 0 989
+0 0 0 0 0 0 0 0 988 987 0 986 0 0 0 985 0 0 0 0 0 0 0 984 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 983 0 982 981 0 0 980 979 0 978 0 0 0 0 977 976 0 975 0 0 0 974 0
+0 0 0 0 0 0 0 973 972 0 971 0 0 0 970 0 0 0 0 0 0 0 969 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 968 967 0 966 0 0 0 965 0 0 0 0 0 0 0 964 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+963 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 962 0
+961 960 0 0 959 958 0 957 0 0 0 0 956 955 0 954 0 0 0 953 0 0 0 0 0 0 0 0 952
+951 0 950 0 0 0 949 0 0 0 0 0 0 0 948 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 947 946 0
+945 0 0 0 944 0 0 0 0 0 0 0 943 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 942 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 941 940 0 939 0 0 0 938 0 0 0
+0 0 0 0 937 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 936 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 935 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 934 0 0 0 933 0 932 931 0 0 0 0 930 0 929 928 0 0 927 926 0 925 0 0
+0 0 0 0 924 0 923 922 0 0 921 920 0 919 0 0 0 0 918 917 0 916 0 0 0 915 0 0 0 0
+0 0 0 0 0 0 914 0 913 912 0 0 911 910 0 909 0 0 0 0 908 907 0 906 0 0 0 905 0 0
+0 0 0 0 0 0 904 903 0 902 0 0 0 901 0 0 0 0 0 0 0 900 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 899 0 898 897 0 0 896 895 0 894 0 0 0 0 893 892 0 891 0 0 0 890 0 0 0
+0 0 0 0 0 889 888 0 887 0 0 0 886 0 0 0 0 0 0 0 885 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 884 883 0 882 0 0 0 881 0 0 0 0 0 0 0 880 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 879
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 878 0 877
+876 0 0 875 874 0 873 0 0 0 0 872 871 0 870 0 0 0 869 0 0 0 0 0 0 0 0 868 867 0
+866 0 0 0 865 0 0 0 0 0 0 0 864 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 863 862 0 861 0
+0 0 860 0 0 0 0 0 0 0 859 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 858 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 857 856 0 855 0 0 0 854 0 0 0 0 0 0
+0 853 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 852 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 851 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+850 0 849 848 0 0 847 846 0 845 0 0 0 0 844 843 0 842 0 0 0 841 0 0 0 0 0 0 0 0
+840 839 0 838 0 0 0 837 0 0 0 0 0 0 0 836 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 835
+834 0 833 0 0 0 832 0 0 0 0 0 0 0 831 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 830 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 829 828 0 827 0 0 0 826
+0 0 0 0 0 0 0 825 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 824 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 823 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 822 821 0 820 0 0 0 819 0 0 0 0 0 0 0 818 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+817 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 816 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 10 0 0 0 0 0 0 0 815 0 0 0 814 0 813 812 0 0 0 0 0 0 0 0 811 0 0 0 810 0 809
+808 0 0 0 0 807 0 806 805 0 0 804 803 0 802 0 0 0 0 0 0 0 0 0 0 801 0 0 0 800 0
+799 798 0 0 0 0 797 0 796 795 0 0 794 793 0 792 0 0 0 0 0 0 791 0 790 789 0 0
+788 787 0 786 0 0 0 0 785 784 0 783 0 0 0 782 0 0 0 0 0 0 0 0 0 0 0 0 0 0 781 0
+0 0 780 0 779 778 0 0 0 0 777 0 776 775 0 0 774 773 0 772 0 0 0 0 0 0 771 0 770
+769 0 0 768 767 0 766 0 0 0 0 765 764 0 763 0 0 0 762 0 0 0 0 0 0 0 0 0 0 761 0
+760 759 0 0 758 757 0 756 0 0 0 0 755 754 0 753 0 0 0 752 0 0 0 0 0 0 0 0 751
+750 0 749 0 0 0 748 0 0 0 0 0 0 0 747 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 746 0 0 0 745 0 744 743 0 0 0 0 742 0 741 740 0 0 739 738 0 737 0 0 0 0 0 0
+736 0 735 734 0 0 733 732 0 731 0 0 0 0 730 729 0 728 0 0 0 727 0 0 0 0 0 0 0 0
+0 0 726 0 725 724 0 0 723 722 0 721 0 0 0 0 720 719 0 718 0 0 0 717 0 0 0 0 0 0
+0 0 716 715 0 714 0 0 0 713 0 0 0 0 0 0 0 712 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 711 0 710 709 0 0 708 707 0 706 0 0 0 0 705 704 0 703 0 0 0 702 0 0 0 0 0 0 0
+0 701 700 0 699 0 0 0 698 0 0 0 0 0 0 0 697 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 696
+695 0 694 0 0 0 693 0 0 0 0 0 0 0 692 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 691 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 690 0 0 0
+689 0 688 687 0 0 0 0 686 0 685 684 0 0 683 682 0 681 0 0 0 0 0 0 680 0 679 678
+0 0 677 676 0 675 0 0 0 0 674 673 0 672 0 0 0 671 0 0 0 0 0 0 0 0 0 0 670 0 669
+668 0 0 667 666 0 665 0 0 0 0 664 663 0 662 0 0 0 661 0 0 0 0 0 0 0 0 660 659 0
+658 0 0 0 657 0 0 0 0 0 0 0 656 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 655 0 654
+653 0 0 652 651 0 650 0 0 0 0 649 648 0 647 0 0 0 646 0 0 0 0 0 0 0 0 645 644 0
+643 0 0 0 642 0 0 0 0 0 0 0 641 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 640 639 0 638 0
+0 0 637 0 0 0 0 0 0 0 636 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 635 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 634 0 633 632 0 0 631 630 0 629
+0 0 0 0 628 627 0 626 0 0 0 625 0 0 0 0 0 0 0 0 624 623 0 622 0 0 0 621 0 0 0 0
+0 0 0 620 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 619 618 0 617 0 0 0 616 0 0 0 0 0 0 0
+615 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 614 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 613 612 0 611 0 0 0 610 0 0 0 0 0 0 0 609 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 608 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+607 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 606 0 0 0 605 0
+604 603 0 0 0 0 602 0 601 600 0 0 599 598 0 597 0 0 0 0 0 0 596 0 595 594 0 0
+593 592 0 591 0 0 0 0 590 589 0 588 0 0 0 587 0 0 0 0 0 0 0 0 0 0 586 0 585 584
+0 0 583 582 0 581 0 0 0 0 580 579 0 578 0 0 0 577 0 0 0 0 0 0 0 0 576 575 0 574
+0 0 0 573 0 0 0 0 0 0 0 572 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 571 0 570 569 0
+0 568 567 0 566 0 0 0 0 565 564 0 563 0 0 0 562 0 0 0 0 0 0 0 0 561 560 0 559 0
+0 0 558 0 0 0 0 0 0 0 557 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 556 555 0 554 0 0 0
+553 0 0 0 0 0 0 0 552 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 551 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 550 0 549 548 0 0 547 546 0 545 0 0
+0 0 544 543 0 542 0 0 0 541 0 0 0 0 0 0 0 0 540 539 0 538 0 0 0 537 0 0 0 0 0 0
+0 536 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 535 534 0 533 0 0 0 532 0 0 0 0 0 0 0 531
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 530 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 529 528 0 527 0 0 0 526 0 0 0 0 0 0 0 525 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 524 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 523
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 522 0 521 520 0 0 519 518 0
+517 0 0 0 0 516 515 0 514 0 0 0 513 0 0 0 0 0 0 0 0 512 511 0 510 0 0 0 509 0 0
+0 0 0 0 0 508 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 507 506 0 505 0 0 0 504 0 0 0 0 0
+0 0 503 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 502 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 501 500 0 499 0 0 0 498 0 0 0 0 0 0 0 497 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 496 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 495 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 494 493 0 492 0 0 0 491
+0 0 0 0 0 0 0 490 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 489 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 488 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 487 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 486 0 0 0 485 0 484 483 0 0 0 0 482 0 481
+480 0 0 479 478 0 477 0 0 0 0 0 0 476 0 475 474 0 0 473 472 0 471 0 0 0 0 470
+469 0 468 0 0 0 467 0 0 0 0 0 0 0 0 0 0 466 0 465 464 0 0 463 462 0 461 0 0 0 0
+460 459 0 458 0 0 0 457 0 0 0 0 0 0 0 0 456 455 0 454 0 0 0 453 0 0 0 0 0 0 0
+452 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 451 0 450 449 0 0 448 447 0 446 0 0 0 0
+445 444 0 443 0 0 0 442 0 0 0 0 0 0 0 0 441 440 0 439 0 0 0 438 0 0 0 0 0 0 0
+437 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 436 435 0 434 0 0 0 433 0 0 0 0 0 0 0 432 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 431 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 430 0 429 428 0 0 427 426 0 425 0 0 0 0 424 423 0 422 0 0 0
+421 0 0 0 0 0 0 0 0 420 419 0 418 0 0 0 417 0 0 0 0 0 0 0 416 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 415 414 0 413 0 0 0 412 0 0 0 0 0 0 0 411 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 410 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 409
+408 0 407 0 0 0 406 0 0 0 0 0 0 0 405 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 404 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 403 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 402 0 401 400 0 0 399 398 0 397 0 0 0 0 396 395 0
+394 0 0 0 393 0 0 0 0 0 0 0 0 392 391 0 390 0 0 0 389 0 0 0 0 0 0 0 388 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 387 386 0 385 0 0 0 384 0 0 0 0 0 0 0 383 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 382 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 381 380 0 379 0 0 0 378 0 0 0 0 0 0 0 377 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 376
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 375 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 374 373 0 372 0 0 0 371 0 0 0 0 0 0 0 370 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 369 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 368 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 367 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 366 0 365 364 0 0 363 362 0 361 0 0 0 0 360 359 0 358 0 0 0 357 0 0 0 0 0
+0 0 0 356 355 0 354 0 0 0 353 0 0 0 0 0 0 0 352 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+351 350 0 349 0 0 0 348 0 0 0 0 0 0 0 347 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 346 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 345 344 0 343 0 0 0
+342 0 0 0 0 0 0 0 341 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 340 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 339 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 338 337 0 336 0 0 0 335 0 0 0 0 0 0 0 334 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 333 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 332 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 331 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 330 329 0 328 0 0 0
+327 0 0 0 0 0 0 0 326 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 325 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 324 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 323 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 1 }
+
+! This is a lookup table for all non-flush hands consisting of five unique
+! ranks (i.e. either Straights or High Card hands). A zero means that specific
+! combination is not possible with this type of hand.
+CONSTANT: unique5-table
+{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1608 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 7462 0 0 0 0 0 0 0 7461 0 0 0 7460 0 7459 1607 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 7458 0 0 0 0 0 0 0 7457 0 0 0 7456 0 7455 7454 0 0 0 0 0 0
+0 0 7453 0 0 0 7452 0 7451 7450 0 0 0 0 7449 0 7448 7447 0 0 7446 7445 0 1606 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7444 0 0 0 0 0 0 0 7443 0 0 0 7442 0 7441
+7440 0 0 0 0 0 0 0 0 7439 0 0 0 7438 0 7437 7436 0 0 0 0 7435 0 7434 7433 0 0
+7432 7431 0 7430 0 0 0 0 0 0 0 0 0 0 7429 0 0 0 7428 0 7427 7426 0 0 0 0 7425 0
+7424 7423 0 0 7422 7421 0 7420 0 0 0 0 0 0 7419 0 7418 7417 0 0 7416 7415 0
+7414 0 0 0 0 7413 7412 0 7411 0 0 0 1605 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 7410 0 0 0 0 0 0 0 7409 0 0 0 7408 0 7407 7406 0 0 0 0 0 0 0 0 7405 0 0 0
+7404 0 7403 7402 0 0 0 0 7401 0 7400 7399 0 0 7398 7397 0 7396 0 0 0 0 0 0 0 0
+0 0 7395 0 0 0 7394 0 7393 7392 0 0 0 0 7391 0 7390 7389 0 0 7388 7387 0 7386 0
+0 0 0 0 0 7385 0 7384 7383 0 0 7382 7381 0 7380 0 0 0 0 7379 7378 0 7377 0 0 0
+7376 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7375 0 0 0 7374 0 7373 7372 0 0 0 0 7371 0
+7370 7369 0 0 7368 7367 0 7366 0 0 0 0 0 0 7365 0 7364 7363 0 0 7362 7361 0
+7360 0 0 0 0 7359 7358 0 7357 0 0 0 7356 0 0 0 0 0 0 0 0 0 0 7355 0 7354 7353 0
+0 7352 7351 0 7350 0 0 0 0 7349 7348 0 7347 0 0 0 7346 0 0 0 0 0 0 0 0 7345
+7344 0 7343 0 0 0 7342 0 0 0 0 0 0 0 1604 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 7341 0 0 0 0 0 0 0 7340 0 0 0 7339 0 7338 7337 0 0 0 0 0
+0 0 0 7336 0 0 0 7335 0 7334 7333 0 0 0 0 7332 0 7331 7330 0 0 7329 7328 0 7327
+0 0 0 0 0 0 0 0 0 0 7326 0 0 0 7325 0 7324 7323 0 0 0 0 7322 0 7321 7320 0 0
+7319 7318 0 7317 0 0 0 0 0 0 7316 0 7315 7314 0 0 7313 7312 0 7311 0 0 0 0 7310
+7309 0 7308 0 0 0 7307 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7306 0 0 0 7305 0 7304 7303
+0 0 0 0 7302 0 7301 7300 0 0 7299 7298 0 7297 0 0 0 0 0 0 7296 0 7295 7294 0 0
+7293 7292 0 7291 0 0 0 0 7290 7289 0 7288 0 0 0 7287 0 0 0 0 0 0 0 0 0 0 7286 0
+7285 7284 0 0 7283 7282 0 7281 0 0 0 0 7280 7279 0 7278 0 0 0 7277 0 0 0 0 0 0
+0 0 7276 7275 0 7274 0 0 0 7273 0 0 0 0 0 0 0 7272 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 7271 0 0 0 7270 0 7269 7268 0 0 0 0 7267 0 7266 7265 0 0 7264
+7263 0 7262 0 0 0 0 0 0 7261 0 7260 7259 0 0 7258 7257 0 7256 0 0 0 0 7255 7254
+0 7253 0 0 0 7252 0 0 0 0 0 0 0 0 0 0 7251 0 7250 7249 0 0 7248 7247 0 7246 0 0
+0 0 7245 7244 0 7243 0 0 0 7242 0 0 0 0 0 0 0 0 7241 7240 0 7239 0 0 0 7238 0 0
+0 0 0 0 0 7237 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7236 0 7235 7234 0 0 7233
+7232 0 7231 0 0 0 0 7230 7229 0 7228 0 0 0 7227 0 0 0 0 0 0 0 0 7226 7225 0
+7224 0 0 0 7223 0 0 0 0 0 0 0 7222 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7221 7220 0
+7219 0 0 0 7218 0 0 0 0 0 0 0 7217 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1603 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 7216 0 0 0 0 0 0 0 7215 0 0 0 7214 0 7213 7212 0 0 0 0 0 0 0 0 7211 0 0 0
+7210 0 7209 7208 0 0 0 0 7207 0 7206 7205 0 0 7204 7203 0 7202 0 0 0 0 0 0 0 0
+0 0 7201 0 0 0 7200 0 7199 7198 0 0 0 0 7197 0 7196 7195 0 0 7194 7193 0 7192 0
+0 0 0 0 0 7191 0 7190 7189 0 0 7188 7187 0 7186 0 0 0 0 7185 7184 0 7183 0 0 0
+7182 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7181 0 0 0 7180 0 7179 7178 0 0 0 0 7177 0
+7176 7175 0 0 7174 7173 0 7172 0 0 0 0 0 0 7171 0 7170 7169 0 0 7168 7167 0
+7166 0 0 0 0 7165 7164 0 7163 0 0 0 7162 0 0 0 0 0 0 0 0 0 0 7161 0 7160 7159 0
+0 7158 7157 0 7156 0 0 0 0 7155 7154 0 7153 0 0 0 7152 0 0 0 0 0 0 0 0 7151
+7150 0 7149 0 0 0 7148 0 0 0 0 0 0 0 7147 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 7146 0 0 0 7145 0 7144 7143 0 0 0 0 7142 0 7141 7140 0 0 7139 7138 0 7137
+0 0 0 0 0 0 7136 0 7135 7134 0 0 7133 7132 0 7131 0 0 0 0 7130 7129 0 7128 0 0
+0 7127 0 0 0 0 0 0 0 0 0 0 7126 0 7125 7124 0 0 7123 7122 0 7121 0 0 0 0 7120
+7119 0 7118 0 0 0 7117 0 0 0 0 0 0 0 0 7116 7115 0 7114 0 0 0 7113 0 0 0 0 0 0
+0 7112 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7111 0 7110 7109 0 0 7108 7107 0
+7106 0 0 0 0 7105 7104 0 7103 0 0 0 7102 0 0 0 0 0 0 0 0 7101 7100 0 7099 0 0 0
+7098 0 0 0 0 0 0 0 7097 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7096 7095 0 7094 0 0 0
+7093 0 0 0 0 0 0 0 7092 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7091 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7090 0 0 0 7089 0 7088
+7087 0 0 0 0 7086 0 7085 7084 0 0 7083 7082 0 7081 0 0 0 0 0 0 7080 0 7079 7078
+0 0 7077 7076 0 7075 0 0 0 0 7074 7073 0 7072 0 0 0 7071 0 0 0 0 0 0 0 0 0 0
+7070 0 7069 7068 0 0 7067 7066 0 7065 0 0 0 0 7064 7063 0 7062 0 0 0 7061 0 0 0
+0 0 0 0 0 7060 7059 0 7058 0 0 0 7057 0 0 0 0 0 0 0 7056 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 7055 0 7054 7053 0 0 7052 7051 0 7050 0 0 0 0 7049 7048 0 7047 0
+0 0 7046 0 0 0 0 0 0 0 0 7045 7044 0 7043 0 0 0 7042 0 0 0 0 0 0 0 7041 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 7040 7039 0 7038 0 0 0 7037 0 0 0 0 0 0 0 7036 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 7035 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 7034 0 7033 7032 0 0 7031 7030 0 7029 0 0 0 0 7028 7027 0 7026
+0 0 0 7025 0 0 0 0 0 0 0 0 7024 7023 0 7022 0 0 0 7021 0 0 0 0 0 0 0 7020 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 7019 7018 0 7017 0 0 0 7016 0 0 0 0 0 0 0 7015 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 7014 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 7013 7012 0 7011 0 0 0 7010 0 0 0 0 0 0 0 7009 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 7008 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+1602 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 7007 0 0 0 0 0 0 0 7006 0 0 0 7005 0 7004 7003 0 0 0 0 0 0 0 0 7002 0 0 0
+7001 0 7000 6999 0 0 0 0 6998 0 6997 6996 0 0 6995 6994 0 6993 0 0 0 0 0 0 0 0
+0 0 6992 0 0 0 6991 0 6990 6989 0 0 0 0 6988 0 6987 6986 0 0 6985 6984 0 6983 0
+0 0 0 0 0 6982 0 6981 6980 0 0 6979 6978 0 6977 0 0 0 0 6976 6975 0 6974 0 0 0
+6973 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6972 0 0 0 6971 0 6970 6969 0 0 0 0 6968 0
+6967 6966 0 0 6965 6964 0 6963 0 0 0 0 0 0 6962 0 6961 6960 0 0 6959 6958 0
+6957 0 0 0 0 6956 6955 0 6954 0 0 0 6953 0 0 0 0 0 0 0 0 0 0 6952 0 6951 6950 0
+0 6949 6948 0 6947 0 0 0 0 6946 6945 0 6944 0 0 0 6943 0 0 0 0 0 0 0 0 6942
+6941 0 6940 0 0 0 6939 0 0 0 0 0 0 0 6938 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 6937 0 0 0 6936 0 6935 6934 0 0 0 0 6933 0 6932 6931 0 0 6930 6929 0 6928
+0 0 0 0 0 0 6927 0 6926 6925 0 0 6924 6923 0 6922 0 0 0 0 6921 6920 0 6919 0 0
+0 6918 0 0 0 0 0 0 0 0 0 0 6917 0 6916 6915 0 0 6914 6913 0 6912 0 0 0 0 6911
+6910 0 6909 0 0 0 6908 0 0 0 0 0 0 0 0 6907 6906 0 6905 0 0 0 6904 0 0 0 0 0 0
+0 6903 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6902 0 6901 6900 0 0 6899 6898 0
+6897 0 0 0 0 6896 6895 0 6894 0 0 0 6893 0 0 0 0 0 0 0 0 6892 6891 0 6890 0 0 0
+6889 0 0 0 0 0 0 0 6888 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6887 6886 0 6885 0 0 0
+6884 0 0 0 0 0 0 0 6883 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6882 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6881 0 0 0 6880 0 6879
+6878 0 0 0 0 6877 0 6876 6875 0 0 6874 6873 0 6872 0 0 0 0 0 0 6871 0 6870 6869
+0 0 6868 6867 0 6866 0 0 0 0 6865 6864 0 6863 0 0 0 6862 0 0 0 0 0 0 0 0 0 0
+6861 0 6860 6859 0 0 6858 6857 0 6856 0 0 0 0 6855 6854 0 6853 0 0 0 6852 0 0 0
+0 0 0 0 0 6851 6850 0 6849 0 0 0 6848 0 0 0 0 0 0 0 6847 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 6846 0 6845 6844 0 0 6843 6842 0 6841 0 0 0 0 6840 6839 0 6838 0
+0 0 6837 0 0 0 0 0 0 0 0 6836 6835 0 6834 0 0 0 6833 0 0 0 0 0 0 0 6832 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 6831 6830 0 6829 0 0 0 6828 0 0 0 0 0 0 0 6827 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 6826 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 6825 0 6824 6823 0 0 6822 6821 0 6820 0 0 0 0 6819 6818 0 6817
+0 0 0 6816 0 0 0 0 0 0 0 0 6815 6814 0 6813 0 0 0 6812 0 0 0 0 0 0 0 6811 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 6810 6809 0 6808 0 0 0 6807 0 0 0 0 0 0 0 6806 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 6805 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 6804 6803 0 6802 0 0 0 6801 0 0 0 0 0 0 0 6800 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 6799 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+6798 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6797 0 0 0
+6796 0 6795 6794 0 0 0 0 6793 0 6792 6791 0 0 6790 6789 0 6788 0 0 0 0 0 0 6787
+0 6786 6785 0 0 6784 6783 0 6782 0 0 0 0 6781 6780 0 6779 0 0 0 6778 0 0 0 0 0
+0 0 0 0 0 6777 0 6776 6775 0 0 6774 6773 0 6772 0 0 0 0 6771 6770 0 6769 0 0 0
+6768 0 0 0 0 0 0 0 0 6767 6766 0 6765 0 0 0 6764 0 0 0 0 0 0 0 6763 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 6762 0 6761 6760 0 0 6759 6758 0 6757 0 0 0 0 6756 6755
+0 6754 0 0 0 6753 0 0 0 0 0 0 0 0 6752 6751 0 6750 0 0 0 6749 0 0 0 0 0 0 0
+6748 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6747 6746 0 6745 0 0 0 6744 0 0 0 0 0 0 0
+6743 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6742 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 6741 0 6740 6739 0 0 6738 6737 0 6736 0 0 0 0 6735
+6734 0 6733 0 0 0 6732 0 0 0 0 0 0 0 0 6731 6730 0 6729 0 0 0 6728 0 0 0 0 0 0
+0 6727 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6726 6725 0 6724 0 0 0 6723 0 0 0 0 0 0
+0 6722 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6721 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 6720 6719 0 6718 0 0 0 6717 0 0 0 0 0 0 0 6716 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 6715 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 6714 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6713 0
+6712 6711 0 0 6710 6709 0 6708 0 0 0 0 6707 6706 0 6705 0 0 0 6704 0 0 0 0 0 0
+0 0 6703 6702 0 6701 0 0 0 6700 0 0 0 0 0 0 0 6699 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 6698 6697 0 6696 0 0 0 6695 0 0 0 0 0 0 0 6694 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 6693 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6692
+6691 0 6690 0 0 0 6689 0 0 0 0 0 0 0 6688 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6687 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6686 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6685 6684 0 6683 0 0 0 6682 0 0 0 0 0 0 0
+6681 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6680 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 6679 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1601
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1609 0 0 0 0 0 0 0 6678 0 0 0 6677
+0 6676 6675 0 0 0 0 0 0 0 0 6674 0 0 0 6673 0 6672 6671 0 0 0 0 6670 0 6669
+6668 0 0 6667 6666 0 6665 0 0 0 0 0 0 0 0 0 0 6664 0 0 0 6663 0 6662 6661 0 0 0
+0 6660 0 6659 6658 0 0 6657 6656 0 6655 0 0 0 0 0 0 6654 0 6653 6652 0 0 6651
+6650 0 6649 0 0 0 0 6648 6647 0 6646 0 0 0 6645 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+6644 0 0 0 6643 0 6642 6641 0 0 0 0 6640 0 6639 6638 0 0 6637 6636 0 6635 0 0 0
+0 0 0 6634 0 6633 6632 0 0 6631 6630 0 6629 0 0 0 0 6628 6627 0 6626 0 0 0 6625
+0 0 0 0 0 0 0 0 0 0 6624 0 6623 6622 0 0 6621 6620 0 6619 0 0 0 0 6618 6617 0
+6616 0 0 0 6615 0 0 0 0 0 0 0 0 6614 6613 0 6612 0 0 0 6611 0 0 0 0 0 0 0 6610
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6609 0 0 0 6608 0 6607 6606 0 0 0 0
+6605 0 6604 6603 0 0 6602 6601 0 6600 0 0 0 0 0 0 6599 0 6598 6597 0 0 6596
+6595 0 6594 0 0 0 0 6593 6592 0 6591 0 0 0 6590 0 0 0 0 0 0 0 0 0 0 6589 0 6588
+6587 0 0 6586 6585 0 6584 0 0 0 0 6583 6582 0 6581 0 0 0 6580 0 0 0 0 0 0 0 0
+6579 6578 0 6577 0 0 0 6576 0 0 0 0 0 0 0 6575 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 6574 0 6573 6572 0 0 6571 6570 0 6569 0 0 0 0 6568 6567 0 6566 0 0 0 6565 0
+0 0 0 0 0 0 0 6564 6563 0 6562 0 0 0 6561 0 0 0 0 0 0 0 6560 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 6559 6558 0 6557 0 0 0 6556 0 0 0 0 0 0 0 6555 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 6554 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 6553 0 0 0 6552 0 6551 6550 0 0 0 0 6549 0 6548 6547 0 0 6546
+6545 0 6544 0 0 0 0 0 0 6543 0 6542 6541 0 0 6540 6539 0 6538 0 0 0 0 6537 6536
+0 6535 0 0 0 6534 0 0 0 0 0 0 0 0 0 0 6533 0 6532 6531 0 0 6530 6529 0 6528 0 0
+0 0 6527 6526 0 6525 0 0 0 6524 0 0 0 0 0 0 0 0 6523 6522 0 6521 0 0 0 6520 0 0
+0 0 0 0 0 6519 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6518 0 6517 6516 0 0 6515
+6514 0 6513 0 0 0 0 6512 6511 0 6510 0 0 0 6509 0 0 0 0 0 0 0 0 6508 6507 0
+6506 0 0 0 6505 0 0 0 0 0 0 0 6504 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6503 6502 0
+6501 0 0 0 6500 0 0 0 0 0 0 0 6499 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6498 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6497 0 6496 6495 0 0
+6494 6493 0 6492 0 0 0 0 6491 6490 0 6489 0 0 0 6488 0 0 0 0 0 0 0 0 6487 6486
+0 6485 0 0 0 6484 0 0 0 0 0 0 0 6483 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6482 6481
+0 6480 0 0 0 6479 0 0 0 0 0 0 0 6478 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6477 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6476 6475 0 6474 0 0 0
+6473 0 0 0 0 0 0 0 6472 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6471 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6470 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 6469 0 0 0 6468 0 6467 6466 0 0 0 0 6465 0 6464
+6463 0 0 6462 6461 0 6460 0 0 0 0 0 0 6459 0 6458 6457 0 0 6456 6455 0 6454 0 0
+0 0 6453 6452 0 6451 0 0 0 6450 0 0 0 0 0 0 0 0 0 0 6449 0 6448 6447 0 0 6446
+6445 0 6444 0 0 0 0 6443 6442 0 6441 0 0 0 6440 0 0 0 0 0 0 0 0 6439 6438 0
+6437 0 0 0 6436 0 0 0 0 0 0 0 6435 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6434 0
+6433 6432 0 0 6431 6430 0 6429 0 0 0 0 6428 6427 0 6426 0 0 0 6425 0 0 0 0 0 0
+0 0 6424 6423 0 6422 0 0 0 6421 0 0 0 0 0 0 0 6420 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 6419 6418 0 6417 0 0 0 6416 0 0 0 0 0 0 0 6415 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 6414 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6413
+0 6412 6411 0 0 6410 6409 0 6408 0 0 0 0 6407 6406 0 6405 0 0 0 6404 0 0 0 0 0
+0 0 0 6403 6402 0 6401 0 0 0 6400 0 0 0 0 0 0 0 6399 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 6398 6397 0 6396 0 0 0 6395 0 0 0 0 0 0 0 6394 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 6393 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6392
+6391 0 6390 0 0 0 6389 0 0 0 0 0 0 0 6388 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6387 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6386 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6385 0 6384 6383 0 0 6382 6381 0 6380 0 0
+0 0 6379 6378 0 6377 0 0 0 6376 0 0 0 0 0 0 0 0 6375 6374 0 6373 0 0 0 6372 0 0
+0 0 0 0 0 6371 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6370 6369 0 6368 0 0 0 6367 0 0
+0 0 0 0 0 6366 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6365 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6364 6363 0 6362 0 0 0 6361 0 0 0 0 0 0 0
+6360 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6359 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 6358 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+6357 6356 0 6355 0 0 0 6354 0 0 0 0 0 0 0 6353 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+6352 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6351 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6350 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6349 0
+0 0 6348 0 6347 6346 0 0 0 0 6345 0 6344 6343 0 0 6342 6341 0 6340 0 0 0 0 0 0
+6339 0 6338 6337 0 0 6336 6335 0 6334 0 0 0 0 6333 6332 0 6331 0 0 0 6330 0 0 0
+0 0 0 0 0 0 0 6329 0 6328 6327 0 0 6326 6325 0 6324 0 0 0 0 6323 6322 0 6321 0
+0 0 6320 0 0 0 0 0 0 0 0 6319 6318 0 6317 0 0 0 6316 0 0 0 0 0 0 0 6315 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 6314 0 6313 6312 0 0 6311 6310 0 6309 0 0 0 0 6308
+6307 0 6306 0 0 0 6305 0 0 0 0 0 0 0 0 6304 6303 0 6302 0 0 0 6301 0 0 0 0 0 0
+0 6300 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6299 6298 0 6297 0 0 0 6296 0 0 0 0 0 0
+0 6295 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6294 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6293 0 6292 6291 0 0 6290 6289 0 6288 0 0 0 0
+6287 6286 0 6285 0 0 0 6284 0 0 0 0 0 0 0 0 6283 6282 0 6281 0 0 0 6280 0 0 0 0
+0 0 0 6279 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6278 6277 0 6276 0 0 0 6275 0 0 0 0
+0 0 0 6274 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6273 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6272 6271 0 6270 0 0 0 6269 0 0 0 0 0 0 0 6268 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 6267 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 6266 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6265
+0 6264 6263 0 0 6262 6261 0 6260 0 0 0 0 6259 6258 0 6257 0 0 0 6256 0 0 0 0 0
+0 0 0 6255 6254 0 6253 0 0 0 6252 0 0 0 0 0 0 0 6251 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 6250 6249 0 6248 0 0 0 6247 0 0 0 0 0 0 0 6246 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 6245 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6244
+6243 0 6242 0 0 0 6241 0 0 0 0 0 0 0 6240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6239 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6238 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6237 6236 0 6235 0 0 0 6234 0 0 0 0 0 0 0
+6233 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 6231 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6230
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 6229 0 6228 6227 0 0 6226 6225 0 6224 0 0 0 0 6223 6222 0
+6221 0 0 0 6220 0 0 0 0 0 0 0 0 6219 6218 0 6217 0 0 0 6216 0 0 0 0 0 0 0 6215
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6214 6213 0 6212 0 0 0 6211 0 0 0 0 0 0 0 6210
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6209 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 6208 6207 0 6206 0 0 0 6205 0 0 0 0 0 0 0 6204 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 6203 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 6202 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6201 6200 0 6199 0
+0 0 6198 0 0 0 0 0 0 0 6197 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6196 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6195 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 6194 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6193 6192 0 6191 0 0 0 6190 0 0 0 0 0 0
+0 6189 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6188 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 6187 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+6186 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 1600 }
+
+! This is a lookup table for the perfect hash adjustment values.
+CONSTANT: adjustments-table
+{ 0 5628 7017 1298 2918 2442 8070 6383 6383 7425 2442 5628 8044 7425 3155 6383
+2918 7452 1533 6849 5586 7452 7452 1533 2209 6029 2794 3509 7992 7733 7452 131
+6029 4491 1814 7452 6110 3155 7077 6675 532 1334 7555 5325 3056 1403 1403 3969
+4491 1403 7592 522 8070 1403 0 1905 3584 2918 922 3304 6675 0 7622 7017 3210
+2139 1403 5225 0 3969 7992 5743 5499 5499 5345 7452 522 305 3056 7017 7017 2139
+1338 3056 7452 1403 6799 3204 3290 4099 1814 2191 4099 5743 1570 1334 7363 1905
+0 6799 4400 1480 6029 1905 0 7525 2028 2794 131 7646 3155 4986 1858 2442 7992
+1607 3584 4986 706 6029 5345 7622 6322 5196 1905 6847 218 1785 0 4099 2981 6849
+4751 3950 7733 3056 5499 4055 6849 1533 131 5196 2918 3879 5325 2794 6029 0 0
+322 7452 6178 2918 2320 6675 3056 6675 1533 6029 1428 2280 2171 6788 7452 3325
+107 4262 311 5562 7857 6110 2139 4942 4600 1905 0 3083 5345 7452 6675 0 6112
+4099 7017 1338 6799 2918 1232 3584 522 6029 5325 1403 6759 6849 508 6675 2987
+7745 6870 896 7452 1232 4400 12 2981 3850 4491 6849 0 6675 747 4491 7525 6675
+7452 7992 6921 7323 6849 3056 1199 2139 6029 6029 190 4351 7891 4400 7134 1533
+1194 3950 6675 5345 6383 7622 131 1905 2883 6383 1533 5345 2794 4303 1403 0
+1338 2794 992 4871 6383 4099 2794 3889 6184 3304 1905 6383 3950 3056 522 1810
+3975 7622 7452 522 6799 5866 7084 7622 6528 2798 7452 1810 7907 642 5345 1905
+6849 6675 7745 2918 4751 3229 2139 6029 5207 6601 2139 7452 5890 1428 5628 7622
+2139 3146 2400 578 941 7672 1814 3210 1533 4491 12 2918 1900 7425 2794 2987
+3465 1377 3822 3969 3210 859 5499 6878 1377 3056 4027 8065 8065 5207 4400 4303
+3210 3210 0 6675 357 5628 5512 1905 3452 1403 7646 859 6788 3210 2139 378 5663
+7733 870 0 4491 4813 2110 578 2139 3056 4099 1905 1298 4672 2191 3950 5499 3969
+4974 6323 6029 7414 6383 0 4974 3210 795 4099 131 5345 5345 6576 1810 1621 4400
+2918 1905 2442 2679 6322 7452 2110 1403 6383 2653 5132 6856 7841 2794 6110 2028
+6675 7425 6999 7441 6029 183 6675 4400 859 1403 2794 5985 5345 1533 322 4400
+1227 5890 4474 4491 3574 8166 6849 7086 5345 5345 5459 3584 6675 3969 7579 8044
+2295 2577 1480 5743 3304 5499 330 4303 6863 3822 4600 4751 5628 3822 2918 6675
+2400 6663 1403 6849 6029 3145 6110 3210 747 3229 3056 2918 7733 330 4055 7322
+5628 2987 3056 1905 2903 669 5325 2845 4099 5225 6283 4099 5000 642 4055 5345
+8034 2918 1041 5769 7051 1538 2918 3366 608 4303 3921 0 2918 1905 218 6687 5963
+859 3083 2987 896 5056 1905 2918 4415 7966 7646 2883 5628 7017 8029 6528 4474
+6322 5562 6669 4610 7006 }
+
+! This is a lookup table for the perfect hash final hand values.
+CONSTANT: values-table
+{ 148 2934 166 5107 4628 166 166 166 166 3033 166 4692 166 5571 2225 166 5340
+3423 166 3191 1752 166 5212 166 166 3520 166 166 166 1867 166 3313 166 3461 166
+166 3174 1737 5010 5008 166 4344 2868 3877 166 4089 166 5041 4748 4073 4066
+5298 3502 1812 166 5309 166 233 3493 166 166 3728 5236 4252 4010 2149 166 164
+4580 3039 4804 3874 166 6170 2812 166 4334 166 166 166 166 166 166 1862 224
+2131 6081 166 2710 166 166 166 4765 166 1964 5060 166 1897 166 3987 166 166
+5566 2021 166 45 166 166 3283 3932 166 166 3519 166 166 291 166 166 5132 2800
+166 166 166 5531 4054 166 3509 166 166 4908 3028 1756 1910 4671 2729 5224 166
+121 3327 3317 166 181 2371 5541 166 1787 2666 5134 5698 166 5480 3870 166 3823
+166 3165 5343 5123 5089 166 2422 3724 166 2735 1953 5724 4444 4871 166 166 5001
+5512 3133 5171 166 2216 166 4877 4542 166 166 166 5270 166 166 166 1922 69 3547
+166 166 166 166 166 231 4547 5155 3357 3464 166 72 3332 166 4392 5971 3896 4451
+3173 2569 166 4466 2518 1698 2850 5349 166 166 4457 5062 166 2202 1650 2191 166
+1950 2583 166 5293 2032 5893 166 3994 5392 3878 96 166 166 3195 166 4001 1900
+2513 6027 166 166 166 166 5407 166 166 2332 5125 5891 3096 3172 166 166 3065
+166 166 4535 166 166 166 4553 3131 3693 166 2255 2613 166 166 166 166 2866 166
+166 166 2940 5333 3199 166 2628 4312 166 166 1794 4681 2058 3606 166 166 3542
+2166 4696 2520 166 4739 166 2563 166 166 3681 166 166 166 4127 1967 2972 166
+5227 166 166 5551 4255 56 166 5553 3219 4367 166 3218 4749 2886 3695 3711 2228
+166 166 166 2268 5054 3749 4825 166 4933 4992 4530 166 4892 3400 166 197 166
+6078 166 166 3971 166 166 5357 1852 3377 166 5196 3740 5320 166 166 3099 166
+4562 6061 3294 166 166 166 166 3266 3627 2567 166 228 2773 166 166 53 1833 2401
+124 166 4272 3922 5959 2903 3923 166 6155 166 166 166 166 216 166 5247 166 5591
+166 166 82 87 4526 166 166 5439 166 4935 166 3187 1869 166 1764 5500 6023 3356
+166 3350 2457 2455 166 1637 166 3342 166 166 3355 5154 166 276 166 166 166 3371
+5969 166 1665 166 166 166 166 166 166 166 4092 1712 3122 5086 166 166 4906 166
+2591 166 166 166 1894 2997 166 4476 4384 166 4747 4109 2655 166 5978 1636 4898
+166 166 166 166 166 166 166 5207 166 166 3712 3876 91 5876 3786 5998 166 166
+166 4391 166 166 2832 2220 4435 166 166 5796 3156 6112 166 1643 1821 3129 166
+4200 166 5857 166 166 2351 5902 1855 5043 166 3167 5191 3996 5718 4876 3071
+2965 5735 5930 6149 2345 3297 3822 166 166 307 6019 1859 2981 4914 3320 6165
+2328 140 2372 308 166 2280 5081 166 3275 166 159 2399 2327 5489 4690 6059 4492
+4269 6058 166 19 166 3323 5708 128 4812 2949 166 166 2890 2630 5237 166 256
+3673 4621 5380 166 3353 166 1651 2573 1635 4011 3429 3370 3720 166 166 6108
+3848 5104 2851 1998 166 166 5106 20 166 2633 166 166 166 166 5662 125 3651 1731
+4702 166 3197 166 2947 3046 4196 2185 6100 166 2602 2908 2487 166 5232 166 4028
+5919 166 2680 3608 3252 166 4899 166 166 166 166 2529 166 166 166 166 166 2534
+166 2299 4076 166 3643 166 3921 166 166 166 1939 2124 1829 2436 3892 166 3481
+271 5307 1697 166 166 5098 2906 5545 166 5980 3203 166 1903 4626 4674 6118 6097
+5926 4136 1677 3232 4720 166 166 166 229 2012 3620 166 3798 166 166 2609 3489
+3809 166 166 166 166 166 166 166 5826 166 166 166 4903 166 166 166 166 6168 166
+5052 5044 5644 2375 2677 4012 3062 5831 4752 166 4125 2610 2062 3238 292 2533
+5872 51 166 1947 4225 166 2288 4845 166 5788 166 5717 166 166 5549 5619 166
+4165 166 2721 2311 5501 4416 4383 166 166 3068 5499 5936 166 4204 4766 4688
+1870 5220 166 166 166 166 237 2523 6039 3061 2793 3998 166 2545 2309 3144 3679
+3969 166 166 166 4379 3574 205 2808 5822 166 166 2188 4823 4990 5561 5711 166
+5627 6034 5253 3783 5047 4405 166 59 1755 3178 318 166 4710 2933 3409 6062 2821
+166 6099 166 4178 166 166 4122 36 4779 166 166 4323 3073 5410 2101 166 166 44
+5690 166 3265 166 5222 5909 1838 166 4755 2215 166 4082 166 166 3210 5140 3124
+5238 166 5913 2321 166 2416 5976 3918 5078 4218 5703 4897 6011 5685 2214 166
+166 6180 5175 1715 166 166 3760 4497 1808 4826 166 2540 166 166 5513 4971 5915
+166 166 2525 166 4480 42 232 2412 2797 3229 5263 2852 5543 2126 3562 166 2872
+4695 5985 5136 2714 4262 5473 166 4160 4347 166 166 166 166 5271 166 166 5108
+166 166 166 166 5437 4875 3963 4362 5820 5559 4890 4728 166 166 2692 166 4870
+3591 5472 166 2690 166 5854 3817 166 280 166 166 113 4128 3396 166 4264 5058
+2283 166 2281 4916 5671 166 2708 166 166 4589 166 166 4689 166 1686 166 166 166
+166 166 1774 166 166 166 5651 3777 2234 166 3864 18 3589 4592 4777 166 166 5254
+4245 166 166 166 4368 5172 3522 166 4306 153 5230 166 5598 5420 311 2414 4159
+2985 5137 166 2179 1801 166 4595 2083 2020 166 3602 2170 4259 3048 166 166 4193
+2350 166 166 2702 166 4521 166 166 2496 166 4593 2006 166 166 2292 4135 166
+6069 4623 166 166 4827 3995 4291 3243 166 166 166 5622 166 3539 166 166 4915
+4373 2479 3775 6008 5838 4321 1612 5530 166 3773 4267 4086 3081 2261 166 166
+4785 4641 5292 166 4820 5612 5556 166 166 166 4396 6084 3414 166 3331 2380 5921
+4315 2340 166 5511 166 4713 3754 2912 2553 166 3468 5388 166 1932 3540 5834 166
+166 3186 5258 166 4107 166 166 166 166 166 166 166 166 2108 12 2368 2789 166
+166 4148 1878 166 166 2324 4179 2945 2531 166 166 166 4485 3765 2308 166 2754
+166 6102 166 1921 260 2241 166 2592 166 166 166 4964 166 3055 5261 4943 2916
+166 201 5728 166 5759 4314 4730 6024 166 4926 4762 1834 2055 166 40 166 5416
+166 3722 2360 1928 166 4889 4590 5550 3498 166 6003 2029 4106 4346 3758 166
+2753 103 1891 5067 166 3398 2079 5784 3074 3787 166 166 3936 166 5766 166 4847
+3928 5119 166 5181 4602 2605 5712 4523 166 166 4717 166 2227 2181 166 4678 166
+166 4901 166 4980 166 166 166 166 5806 2894 5631 4995 2608 166 166 166 3917 166
+3417 166 2795 1655 3189 3364 166 4839 3510 4212 5641 6091 138 166 166 3343 4620
+2722 4566 166 3518 3424 166 166 1653 166 5057 166 5375 4833 166 4273 4348 166
+166 166 4912 166 3662 166 4281 166 5169 166 5883 2737 2572 4685 4068 166 4214
+166 166 2409 166 166 4571 166 5624 5722 5949 166 3675 166 166 5109 3428 166 166
+5446 166 3290 166 3309 166 166 4776 166 166 166 166 166 166 5617 2860 166 166
+166 166 3629 1741 166 166 183 4973 3047 2854 75 2035 3652 2159 166 4150 6037
+3225 4519 1902 2678 2413 1961 166 166 166 166 4972 1847 166 5636 4017 166 3345
+166 4520 166 2861 166 3092 6060 157 2542 2298 4496 166 2607 6110 5707 2314 166
+166 273 166 5952 166 4957 322 6065 2272 6140 2438 3458 3287 166 166 166 166
+2684 288 3354 166 166 3983 1702 166 166 166 2393 2435 4202 3308 5805 5085 166
+166 1938 166 166 2171 5892 2337 166 4648 3116 2486 4363 3567 166 166 2822 2041
+166 4703 3956 5192 166 3975 5720 3647 2134 5932 166 166 5160 263 166 166 166
+4549 166 166 1701 3086 166 166 4737 166 2252 166 170 166 166 166 2301 5478 166
+166 5979 3007 166 166 166 4104 166 2469 2700 166 4998 3376 166 1840 166 166
+4470 166 5235 3930 166 166 166 6031 166 166 166 3827 4700 166 166 166 166 166
+166 4103 3976 166 166 166 166 5027 4322 5130 166 4741 2132 4118 3080 4137 166
+6179 166 166 166 166 166 6120 4188 166 2251 166 3253 166 4887 166 4293 5241 166
+166 166 166 166 166 5076 166 166 4177 166 221 166 2757 5377 166 43 166 166 3180
+5540 166 213 4541 166 166 166 166 166 1641 166 4578 4639 166 166 1683 2139 1689
+5249 5773 5226 166 2820 166 5516 5045 166 4896 5657 5189 166 5770 2725 5148 166
+166 166 2929 166 3479 166 166 4564 3752 4305 4232 166 5906 1779 166 2709 4941
+4342 166 4882 166 4277 2322 166 4879 1610 3038 166 3762 2054 5652 166 4524 3820
+4806 166 166 104 3416 4869 4243 4854 166 4114 166 2121 166 3463 3556 166 4795
+166 2118 3920 166 166 4667 5046 166 166 2088 4360 5787 2198 4233 5552 3970 3523
+2037 5791 166 166 4299 2336 166 166 166 4173 4588 3626 5187 166 3363 4611 294
+4962 5243 2719 6022 4976 3559 166 2662 5779 6151 166 3527 166 5404 6132 1839
+166 3090 166 2253 166 5441 5518 6049 166 166 6136 3026 3474 5960 166 3937 4105
+166 2348 2039 4738 166 5233 3882 3840 166 278 190 166 5751 4313 166 3855 166
+166 6171 166 166 5381 3941 166 166 166 166 3334 166 2038 6088 166 1918 5037
+2325 2378 4894 3514 3715 5168 166 166 4083 2873 166 166 166 2693 166 3543 166
+2577 3013 166 166 4594 2622 166 166 166 3401 166 166 5447 5328 5547 6133 2335
+3739 166 166 166 166 5614 3492 3610 3466 166 5336 4354 166 4662 166 166 4283
+166 166 303 5904 166 2717 166 166 2276 5564 2386 5661 2040 166 1630 4652 166
+4840 166 110 5329 3979 5734 2550 166 166 6007 5999 2978 4771 5360 166 4023 166
+166 5920 4065 166 3880 166 5422 1813 166 6166 73 166 166 3669 5762 5077 166
+2953 85 166 3517 166 116 166 2738 3710 166 1634 166 166 166 2290 3001 166 166
+3037 2400 3410 166 1791 4231 166 3546 5009 5299 2807 166 166 1675 1619 2374
+3093 5302 3278 2330 5301 2343 2307 3274 5017 2265 3700 2465 166 139 4292 166
+5056 3952 166 4528 2388 1886 166 166 3016 3698 5881 166 2379 3223 166 166 3847
+2407 5493 3183 3307 166 265 166 2421 6161 2057 5363 3863 2474 166 166 5427 166
+2140 2955 166 3070 4237 5018 5988 5570 275 4862 2357 166 195 166 2593 6047 166
+2878 166 166 2781 3004 4180 166 5593 166 5973 2544 5064 166 4324 4701 166 3084
+166 166 5372 4725 166 5650 166 166 2786 166 3781 3583 3682 1850 4420 3296 5173
+4461 166 166 166 2984 166 93 166 166 4336 5943 2922 3300 166 4843 166 166 166
+166 2094 166 2939 166 4656 166 5146 166 166 166 166 2104 3977 4660 5312 166
+1865 166 5487 5558 3380 166 1957 3162 3281 166 3588 3268 2099 166 166 2319 4913
+4187 5503 5782 150 166 52 5450 166 166 166 2941 5877 166 4031 5393 166 3931
+4166 3135 3445 166 5053 5430 4836 166 5315 3389 4636 166 166 3441 166 166 3767
+2961 166 4761 4604 3179 166 166 4751 2148 2015 166 123 5013 166 2936 166 2063
+166 5823 166 5096 166 166 4198 166 166 166 3845 166 166 238 166 2703 3541 166
+4813 166 4477 2349 4197 5996 3324 4789 3063 166 166 5504 5273 2805 13 166 5601
+5402 4119 5206 166 166 4251 3704 4176 1963 2882 166 202 3125 3318 112 166 3362
+4835 3420 3974 5099 166 4433 166 166 166 1766 2663 166 166 4683 166 166 5485 47
+5101 5341 5765 3390 1648 4341 3945 6045 1645 166 5578 2594 166 166 3772 166 166
+3196 3603 166 5399 166 5075 166 5911 4632 4781 5313 270 166 2346 166 166 166
+1986 166 166 4958 166 166 166 4048 166 3076 166 166 4891 166 166 57 166 220 166
+166 166 4117 166 166 166 166 5194 2658 166 166 2942 6071 4182 166 2976 5816 166
+166 166 166 3985 4211 2514 166 166 166 2504 3446 1711 166 166 2107 5190 166 34
+166 3912 5382 3003 166 166 166 2999 2404 4734 4455 2087 166 2405 156 166 2830
+3303 296 3295 2067 4268 166 166 5642 166 166 1901 166 5133 166 166 166 166 3176
+2973 4677 166 166 6164 3000 2396 2734 5697 5989 166 2823 5265 5852 166 166 2623
+2625 2287 4844 1758 166 166 166 166 166 6073 166 5379 2389 5279 2444 5515 166
+4038 166 4948 5640 166 166 3572 4258 166 166 166 5204 166 4603 5797 166 166 166
+1725 4600 166 166 5498 166 4152 166 172 4758 166 2598 2489 2076 4366 2568 166
+4352 3782 166 166 3059 3946 5138 5727 4484 5694 166 3796 166 166 166 166 5334
+1778 2245 166 4517 4419 2250 182 5856 166 2835 4495 1858 2033 6014 6086 3211
+166 166 154 2145 166 129 3661 2661 5860 6143 2640 3890 6160 166 166 2747 166
+166 2291 282 2476 166 166 3825 166 1925 166 4489 166 166 166 4034 166 166 166
+166 166 166 122 4708 4919 2373 2453 5419 5954 297 5290 166 1978 166 4932 3501
+166 3085 3386 166 5405 4512 166 3209 5740 4020 5495 5815 314 166 3190 4824 166
+166 3448 207 1623 6096 5878 166 1836 166 166 2728 166 5278 3419 3012 5618 5266
+3078 166 166 2244 166 4569 6068 166 3336 166 5677 6052 5079 166 5453 5245 5799
+166 1982 166 5958 4619 5821 166 5285 284 1631 5710 6070 5365 2189 3242 166 2752
+5483 5297 6150 5522 166 1815 166 166 166 5801 166 166 5398 166 166 166 2967
+2515 3169 166 166 2562 166 1617 2069 166 166 6154 166 3721 166 5327 166 166 166
+5592 166 166 2286 1716 3903 166 2395 286 3587 6146 3286 4186 5882 5894 5737
+6032 5879 2761 4829 3788 166 166 3233 5356 5693 166 2429 2449 141 3444 5186 166
+166 3477 4080 4584 166 166 3670 1851 3824 4337 3886 2792 166 5867 166 166 3557
+3147 166 166 2200 166 2505 166 4310 4865 5656 5992 5672 166 5199 135 3023 2994
+4472 166 166 166 2019 4319 3472 166 166 166 29 206 3944 3027 5804 4731 5449 166
+2825 3310 166 6172 5202 166 2516 3644 4557 166 166 166 166 2671 4427 3432 3276
+5584 5536 4645 3202 166 2612 166 4249 2425 3259 4622 166 2411 4303 4206 166 166
+166 3734 6063 118 166 166 3641 166 166 166 4937 1871 3421 2208 166 166 166 166
+4881 166 166 166 166 3298 166 61 166 166 166 3293 6145 71 3619 166 166 3383
+1624 320 2187 4113 166 166 166 166 166 5080 2344 5625 2358 1621 4230 5579 5359
+295 4248 5267 3883 6124 187 5112 2122 166 166 166 5142 6004 166 5322 6175 3639
+3182 4425 166 175 166 166 166 5778 3939 3484 166 166 5832 5248 5935 4467 5858
+166 5038 166 166 3102 166 4880 166 166 166 166 3418 1666 5338 3680 5291 4441
+3385 166 5733 4503 2774 166 2631 4153 166 2000 166 166 5345 166 166 4298 1804
+4707 166 1613 1952 2111 166 166 166 166 166 2897 166 166 4044 166 166 166 166
+2863 5475 166 166 166 1704 166 3609 2782 2018 166 5361 166 3694 3733 166 2785
+1969 166 166 2834 1868 3779 1877 60 166 4143 3902 166 4361 3188 2498 6009 166
+115 166 3138 166 4575 6080 133 2030 166 166 166 2306 2136 3043 3447 2142 166
+3799 1646 5269 3640 166 2674 5502 166 5467 166 5069 166 166 4654 4581 5274 5036
+4364 166 3115 166 2128 4544 5433 2086 2584 4413 166 166 5385 166 234 166 1625
+166 166 166 5139 2511 4974 2766 166 166 166 2095 3990 217 166 2988 4061 166 209
+4883 166 166 166 166 166 4326 166 5465 2859 166 2887 166 2231 166 1658 166 2246
+166 1844 166 166 3087 2871 3872 1660 48 166 166 3622 166 1709 166 166 6177 6173
+166 3569 166 166 166 241 3660 3631 166 166 5319 5141 174 166 166 4412 166 5145
+166 1919 166 5276 166 2385 166 1618 166 166 2501 166 166 1734 5966 3145 166
+1690 4025 1664 4559 2433 2392 3552 4006 1896 166 166 2546 4450 5396 4221 4046
+166 166 2642 166 4448 166 2784 3480 4807 166 166 3534 166 166 5272 166 166 2831
+4263 166 166 166 166 4414 5628 3486 166 3748 166 4598 3719 3598 3611 166 4792
+5059 4110 166 2656 166 166 84 5429 166 166 166 281 1955 166 166 166 3616 4997
+166 166 166 166 3230 166 166 166 166 166 166 77 166 166 166 1800 166 4236 166
+166 166 166 166 5757 2530 1662 166 4607 1659 166 1685 3341 166 1699 4058 3407
+1854 4417 3034 166 166 166 166 5568 166 3206 166 5529 166 166 166 2116 3487 144
+166 166 166 5523 5373 5321 166 6064 2921 166 1696 2473 166 166 3716 5689 166
+4608 3879 166 166 166 2156 166 4358 2446 166 3958 166 5520 4340 4848 166 3285
+166 2665 166 3459 1905 5115 68 5730 166 3127 5029 4370 166 3753 166 3674 6025
+4490 166 4183 166 94 166 166 4051 3766 3140 4907 3857 166 166 4596 166 3888
+3040 2507 5643 166 166 4311 2618 5582 166 166 3678 166 1988 166 166 4464 166
+166 166 166 4278 3677 2173 5256 166 166 5162 166 5178 1644 5094 166 2557 5506
+166 166 166 4927 5348 1797 166 166 39 166 3866 3655 236 5403 2175 3361 166 1976
+5993 226 166 4643 166 5339 4098 2653 4969 166 3346 4984 4635 166 166 166 166
+4981 188 166 166 28 4088 166 166 166 25 3663 2696 166 4679 5114 5802 166 166
+166 166 166 3810 5749 166 1673 4276 166 3756 4184 166 5630 166 166 166 4531 212
+5663 166 166 2746 166 5386 3618 3594 1887 166 166 5443 166 1726 4094 5065 4756
+166 166 5308 5225 2081 166 166 3064 166 166 1981 3637 4355 1626 166 166 4686
+166 5793 180 5066 2938 3819 4904 3601 166 166 2495 5025 5768 2621 4650 3041 166
+5897 3633 166 166 4375 166 5714 1667 3273 3950 1668 166 5855 166 2364 166 1881
+166 2646 5460 166 2770 4951 5414 166 4442 2113 5726 298 5934 2053 166 166 4053
+166 166 4514 4697 166 166 5198 2707 166 5605 166 166 5218 2596 166 2110 166
+1806 2160 166 166 2212 166 3636 166 166 4377 4021 3707 4502 166 4195 166 166
+166 4108 3725 3676 166 2084 166 166 166 166 4216 166 166 6156 166 2896 166 166
+166 166 166 166 3826 2870 3793 166 166 5927 166 2759 166 4613 2297 5638 166
+2842 5031 4793 5184 166 166 2008 166 257 2881 117 6051 3044 4079 2833 166 6117
+166 3236 5469 166 166 2874 6076 166 1799 80 41 166 1864 166 5709 1611 5026 5176
+168 3269 4081 166 166 1970 4550 166 4250 4101 4565 5950 5845 97 4064 166 5394
+4374 4343 166 166 4658 3248 166 208 1735 4047 2843 166 166 166 166 2794 166 166
+5844 166 166 3094 2177 5436 3646 166 3564 4682 166 5948 5835 162 2059 5151 2034
+1926 5941 5903 5177 166 166 166 4801 3439 1780 166 166 3280 3434 166 166 4498
+5565 4043 166 4432 4722 3959 166 3746 166 166 177 166 166 2748 166 4483 166 166
+4144 166 166 166 166 2066 2915 166 2049 2130 4684 166 49 3506 5391 166 2590
+6103 1714 2410 3053 3837 4301 166 3255 2644 166 166 4014 166 2475 4788 2876 166
+166 166 166 166 166 4140 166 166 321 166 1966 166 166 2855 3111 3800 166 4446
+2551 166 166 166 2824 166 166 166 2164 3010 2226 166 4857 166 2582 5118 4582
+5917 166 166 3338 3482 3328 166 4817 166 5371 3830 166 3009 1633 3329 4052 166
+3701 4983 4500 4487 4878 166 166 5482 3544 166 3057 2026 4398 2847 3532 3262
+3399 166 166 166 4478 4167 166 3411 2599 5362 166 2711 166 166 166 166 3452
+2522 5586 5548 3279 2538 166 166 166 4161 166 2123 166 166 2660 166 166 1706
+166 15 3537 5051 5869 166 3025 166 4447 3744 120 166 166 166 204 2810 166 5124
+2376 5306 166 166 4493 166 166 166 5289 6046 166 2762 2541 1857 2467 5163 166
+166 166 166 5830 166 2172 3359 166 2928 166 166 166 6129 166 5445 166 166 5924
+6144 166 102 166 166 1678 166 4491 5705 166 1753 166 3873 5725 4145 1909 166
+2155 166 166 1848 3315 1874 166 4945 2524 166 3263 2362 1785 166 166 166 152
+2102 5723 5131 5754 4032 4029 166 4295 3391 166 166 166 5282 1747 3159 2235
+5583 1786 3630 6111 2974 4797 3623 166 2071 4929 166 2603 3964 3378 166 166
+2654 151 3940 4527 4518 166 2430 1884 3812 166 2867 166 166 166 2756 5418 166
+2354 4606 166 2153 166 4855 166 166 1720 166 3213 3926 166 5158 4349 166 4828
+166 166 2031 166 2300 166 166 166 2211 4954 3121 4754 2485 166 166 166 3593 166
+2718 5317 2765 5120 166 2527 166 1994 5947 166 166 166 6085 2302 100 79 2982
+3705 2180 2043 166 1872 1671 166 3729 166 4944 3665 2217 2119 166 5615 166 1620
+166 166 166 166 35 3913 2760 166 3688 3672 4042 166 166 5117 4227 166 4445 2458
+3803 4554 4988 166 166 3141 3491 166 166 166 166 5095 4668 5567 166 166 2885
+1790 2996 166 166 166 166 3737 166 2470 166 166 4339 166 166 166 4920 166 166
+3697 5471 166 166 3538 4558 3467 5262 5609 3858 166 166 5007 2780 2791 2236
+5668 3134 166 166 5776 3470 3291 166 2532 166 166 166 3805 264 166 3227 166 166
+166 2334 166 5087 101 166 3634 58 2813 166 166 166 3222 4704 4488 4508 5459
+2117 5873 166 1828 166 166 166 166 166 2105 166 5613 5761 2920 3098 166 166
+3277 166 166 166 166 83 166 166 166 3967 166 5574 166 4985 30 3426 166 179 3014
+4015 246 2556 4449 3723 5611 3436 166 4240 3642 166 4536 2048 5810 166 1971 166
+5557 5323 5022 191 5492 166 4837 4426 2537 2271 3177 5674 166 2796 1995 166
+3906 166 4403 3862 4716 2406 3948 4670 4309 166 2575 5358 2951 166 3666 3612
+5577 4579 4743 166 6072 6036 4563 2586 166 5836 166 166 5752 166 3563 166 2909
+3251 92 166 4711 4149 166 166 3052 5122 2904 2635 1990 166 166 166 166 166 166
+166 166 4213 166 3103 3142 2683 6105 2209 3175 4215 166 166 166 166 166 166 166
+5303 4075 5374 166 4174 4154 1895 4538 2764 166 5817 6113 4033 166 6090 166
+2990 166 3164 166 166 166 247 166 6083 3412 166 5738 166 3599 166 1904 2162
+2547 3960 166 166 3154 55 166 5991 4921 2879 166 166 5347 166 166 166 2712 4787
+166 1908 166 166 166 3184 166 166 166 4572 3846 3657 166 166 5481 166 166 3397
+1856 4978 166 3900 3570 3802 166 166 2075 4408 166 6079 2313 166 166 5756 166
+166 2070 166 166 3137 166 166 3686 166 166 166 166 67 5019 166 1742 166 5354
+166 5149 166 2931 4946 6006 166 166 2865 4902 3029 1722 3449 166 1987 166 62
+5626 166 166 166 2670 1657 5599 3056 166 3791 5020 166 1979 4437 1899 166 166
+196 2636 166 143 3475 4317 2512 2415 5033 5024 2112 2864 3551 166 1688 33 4585
+3648 4399 166 166 166 166 166 1824 166 166 166 166 166 166 4513 166 2478 4407
+166 166 2492 4130 4318 2980 5746 166 2606 4063 4123 166 255 166 166 4680 166
+3586 5975 3935 166 5528 166 3158 166 166 2614 5035 166 3488 3214 166 166 166
+5413 3713 166 5875 4329 5250 166 166 3741 166 54 1885 3839 166 4924 166 166 166
+4158 166 166 2152 1661 166 166 4327 166 3933 166 5666 166 166 2580 166 3404
+4111 2862 4438 166 166 4072 166 166 3938 2958 4302 166 3851 166 268 166 166
+1975 222 3204 3438 4616 166 4275 3101 2648 3989 5215 166 4229 166 5440 166 5093
+2639 166 166 4439 166 2316 4239 166 166 166 166 166 1817 4486 166 3272 166 166
+4085 2078 2902 166 166 166 4381 1853 3054 166 166 5005 2669 166 2856 2706 166
+166 166 4185 166 1748 166 166 166 5771 166 166 3915 166 166 2205 6122 166 166
+1632 5400 166 2477 4740 166 166 166 1802 166 2472 3953 166 1849 2604 3780 2560
+4786 2566 3576 166 4768 166 1951 251 5068 166 166 166 2619 166 166 166 5432 166
+166 5260 5758 3908 166 4141 166 5777 166 166 166 166 166 3961 5143 166 3889
+3747 3743 166 2818 166 166 166 3867 166 166 3742 4763 2948 5533 166 3966 3555
+3843 3503 6005 166 4687 2790 4479 5828 3769 5688 166 166 166 166 3109 166 166
+166 166 4574 81 166 166 4576 3369 166 166 166 4207 166 5072 2210 166 184 166
+4673 166 166 166 166 166 166 1628 3590 1916 4784 4970 166 1832 166 166 3584
+3384 166 166 2880 1783 166 166 166 166 6115 6121 2157 5428 5859 4861 5635 4331
+5839 4223 313 166 166 6152 2168 166 4112 6089 6012 166 5294 3207 166 166 4884
+166 4655 166 166 166 1743 166 4077 166 4631 166 166 2957 1945 4936 166 166 5389
+166 166 5955 166 166 1639 2207 4129 166 3582 5560 6147 3088 166 166 4529 5259
+3118 166 3106 2853 166 1845 5660 166 3325 3973 2461 2163 166 3083 4190 166 166
+5505 166 166 3226 5507 109 6141 3991 166 4939 166 166 5889 3986 166 3664 4353
+2056 166 5071 166 166 4376 166 1958 2028 166 166 1793 166 5252 3536 166 166
+3525 3580 166 166 166 1782 5174 2011 1826 3352 3231 166 166 4986 2068 2801 166
+2500 166 5061 166 2263 2632 1993 166 2715 4424 166 166 6042 4661 166 5074 5479
+4822 166 166 166 166 5600 5853 166 1907 166 166 166 3808 166 5997 5032 4605 166
+1732 166 166 166 3015 5454 166 166 166 3806 5444 2238 1946 166 166 3221 4922
+166 6092 166 166 4007 166 3425 4282 2571 166 1749 166 166 38 4744 4900 4257 214
+5687 166 2490 2979 2924 166 4714 219 5344 3836 3302 78 1984 2986 2960 166 2869
+3507 3335 4967 2892 2723 4849 5070 166 166 4629 3815 166 4453 4760 166 3224 130
+166 166 166 166 166 3408 2494 2691 166 4325 2932 5165 5573 166 4769 166 5411
+5637 2050 166 166 2305 166 166 4834 24 4693 3554 2491 1738 166 166 166 23 2758
+3072 2564 4800 5537 3545 4133 166 166 166 5982 166 203 166 166 290 185 166 3774
+1929 3379 166 166 166 166 3002 166 3738 166 166 3344 4942 5353 2777 2839 4712
+1830 2664 166 5884 3516 166 5494 4169 2391 3319 166 166 5918 2597 166 4821 2787
+5719 166 166 166 1687 6148 3257 254 166 5180 6153 5964 306 166 6123 166 5208
+166 3163 5938 1736 166 2502 4910 166 166 2549 166 2900 3632 3270 166 2082 5953
+166 107 5750 166 166 166 5527 1751 4168 2950 166 2659 166 4189 1943 2595 166
+4191 166 166 166 166 2998 2296 5221 3617 166 5435 2451 2009 3005 2242 3768 3658
+166 166 166 166 166 2481 2256 166 166 4074 166 3120 166 4409 1759 166 166 1679
+3659 3499 5219 4501 3082 2047 166 166 166 4560 2768 5251 166 166 166 2437 3993
+3215 2447 166 166 166 2993 4963 166 3045 166 166 166 166 166 166 166 5521 166
+166 4868 166 3895 166 6131 3949 3306 3785 166 166 4895 4831 166 1772 166 166
+5928 166 2137 4805 2462 310 2667 3561 166 166 2312 4931 5255 166 166 166 5670
+166 2285 166 4672 5310 166 2103 2174 166 166 166 166 5417 166 4726 4203 166 166
+166 5581 166 5665 166 166 5747 166 166 2509 1973 2749 5463 166 166 4567 5014
+166 3322 3051 166 4090 166 3709 3887 3478 166 166 166 166 3565 3934 166 32 166
+166 166 2239 166 3947 3849 166 2022 166 2169 166 4691 98 166 3804 4155 1640
+4002 166 2138 1739 3730 5970 2274 4873 3119 166 4925 3577 3699 4049 3982 166
+5161 1744 166 166 166 5704 4979 2686 5383 5744 2289 166 166 166 3927 2539 166
+166 166 2585 166 4723 3755 4509 166 4961 2194 2535 166 176 166 4494 166 4171
+166 266 166 3454 5369 166 166 5899 5284 166 3607 3566 5514 166 1843 166 3997
+4599 2743 166 2857 2497 2751 166 166 166 3511 5742 166 166 166 4504 166 166 166
+5082 4401 166 166 5431 166 166 1949 4539 166 166 4852 166 166 3457 166 3433
+4669 166 1692 2454 3258 6159 166 166 166 166 166 2788 4350 3249 3816 4893 166
+4846 166 4993 1708 4138 166 2895 2891 166 1860 166 2480 1927 3853 166 166 166
+5100 166 3143 5159 166 4286 5182 5246 4975 166 2905 166 4917 5102 2044 6016
+5673 2005 5090 166 4634 3333 166 5702 3413 1762 6094 4284 4431 2641 166 4463
+5691 166 166 3442 3473 4192 2046 166 3838 166 3217 3349 166 2243 166 3490 166
+166 166 5922 166 166 166 4885 1798 2884 2750 5004 2741 166 166 5649 166 4410
+166 166 3382 166 166 1913 1703 5532 3770 166 5116 2645 2634 4357 5901 166 166
+5538 166 166 166 6028 166 166 5840 4102 2704 2091 5287 166 4757 2282 166 2650
+3528 64 253 3732 166 166 166 166 166 3465 166 166 166 5848 3110 111 166 166
+3403 2926 6030 3366 1948 4430 5509 3250 3972 2587 3579 166 6048 250 5275 4242
+2615 3112 3558 166 166 2342 166 5157 1917 2733 5647 1934 5675 166 3981 2923
+5213 5326 37 166 5288 3069 166 1923 5755 166 166 166 1888 166 6041 5895 5376
+3727 3901 166 5589 166 166 4609 166 166 166 4706 166 4482 1622 166 171 166 166
+4646 4151 2755 4614 166 2072 5409 4469 1647 4434 4633 1915 166 3615 4808 166
+3388 166 5280 2731 166 166 2417 166 14 166 4533 5126 166 2778 3022 166 166 166
+4830 4764 166 166 166 4982 166 4265 166 2466 5678 147 1883 166 166 166 114 4000
+2427 3597 166 4853 5981 166 2023 2519 166 1937 2221 4676 166 4522 5716 166 2432
+5731 166 6020 6163 4351 2442 4380 166 4390 1882 6139 4246 262 166 1676 5781
+2352 1956 200 166 166 5800 6184 166 2355 149 5962 5524 4238 166 5150 166 5888
+2423 166 5739 3192 4142 166 166 166 3201 161 4460 2459 158 166 166 166 166 2689
+166 166 166 166 1889 166 166 3374 166 70 166 2772 166 2995 166 2384 4989 166
+3299 166 166 166 166 3614 3645 3415 3160 1727 3735 5201 1693 3531 166 166 1776
+3871 166 166 166 166 86 3553 166 166 166 3392 166 166 2232 166 4977 2333 3394
+2875 2027 5736 166 1719 166 4952 2061 2150 5526 166 4637 166 4333 166 166 4733
+4809 3911 166 3460 166 5355 3126 4181 4436 300 166 3841 166 4770 126 5654 166
+166 166 1730 166 166 166 5610 166 6002 2197 3807 6109 166 166 166 166 166 5395
+4004 166 46 166 166 2570 4736 5318 4247 166 166 166 2293 3031 4591 166 245 166
+5510 1616 3117 4163 166 166 4759 3462 4819 4947 166 3128 5946 2278 2969 166 166
+5183 166 166 1729 173 2448 166 230 2971 166 166 5397 166 4093 3348 1866 4280
+166 6067 3794 166 166 166 4729 166 3456 166 2394 166 4953 166 166 2258 4863 166
+166 4060 166 5468 305 166 6134 166 166 2326 166 3453 2167 2845 166 166 166 5597
+166 166 166 166 5462 2809 5994 2899 166 166 166 5153 166 166 1638 166 166 4938
+3795 166 3842 166 166 166 2769 3194 166 4745 5508 5604 3910 166 166 4147 3239
+166 166 3548 3859 2092 166 2705 166 166 3625 4131 166 3513 166 166 2987 4555
+3107 166 166 166 166 5713 4698 3079 166 5342 166 166 2673 2517 2745 1795 166
+166 166 166 166 166 2463 166 166 2445 5425 6138 166 2687 3254 5871 166 2387
+4300 166 166 3529 1996 166 2369 3818 6126 1615 2643 65 4297 166 5324 3311 3852
+166 3868 4199 3978 166 166 166 5466 166 166 244 166 5929 6157 2390 5639 2267
+2073 4610 5774 2521 4556 166 4545 4307 2426 2450 166 5783 4968 6176 4156 166
+166 4126 3549 166 3581 5701 3234 166 4013 1879 166 6104 5874 166 166 3485 4279
+2528 5576 166 3992 166 3980 4934 166 2176 4228 5164 3784 1933 4120 5055 166 166
+5015 166 166 166 2310 1754 166 6087 166 166 4548 5268 2930 166 3656 166 3042
+5229 166 4016 2195 166 166 166 199 1745 3717 166 166 74 2668 252 4124 4657 5223
+166 2186 3628 166 166 166 4222 3114 2841 5103 3171 5135 166 166 2273 166 3899
+5332 5842 3575 2579 2431 2464 2229 3604 4561 2977 2815 166 3916 166 5825 166
+1694 166 4030 166 5841 166 3881 1831 166 5525 3011 166 5535 5217 316 4116 166
+166 2204 166 3136 3650 166 5813 1875 4511 4475 166 1999 166 2277 166 3024 5484
+5546 166 3988 5676 166 2213 2264 5214 166 4940 5974 166 4750 6077 166 1652 3148
+166 166 166 166 2554 166 6167 5257 5300 166 166 166 166 5408 166 166 3402 2141
+166 4663 5633 3312 166 2814 4930 1959 166 166 166 3861 166 166 302 2624 166 166
+166 1629 1724 166 3909 5281 166 2001 4395 5352 4428 2694 4850 166 166 5242 5910
+166 166 166 166 166 3212 166 2045 166 166 166 166 166 166 3017 4960 4456 166
+5616 6093 2151 166 166 166 315 3381 166 166 166 4330 166 6158 4721 6075 166 166
+166 4543 2303 166 166 3301 166 5000 3929 2543 3437 166 166 166 3422 166 5987
+5729 2428 166 4035 5588 3714 3834 5264 5743 166 3305 4886 6107 5156 166 166 166
+166 166 1672 5849 5827 5049 6101 2178 2420 3289 166 166 4274 6017 2257 166 4172
+3451 2367 2382 166 2964 4918 3241 2347 6082 99 2383 166 4454 163 2460 165 304
+1818 5580 166 312 5790 293 5794 5519 5083 3360 5748 166 3750 5034 166 166 166
+1863 3168 166 166 166 5111 166 166 166 166 2183 4510 166 166 3495 4382 4235
+4462 166 4056 5885 17 5028 1614 6038 166 2488 5632 3089 166 1940 66 4039 3999
+235 166 166 3829 3954 166 2365 269 166 166 166 166 166 166 4418 1796 4709 2004
+166 3596 5786 166 2819 4624 3152 2968 2838 166 5575 1767 5603 166 4386 5890 166
+1768 4201 3560 166 166 166 2184 2262 2966 2716 1765 2611 2983 166 4164 4084 142
+5314 166 166 4071 166 2578 2849 3600 166 166 166 166 5401 4814 3431 166 5088
+5084 198 166 3578 3764 166 2097 166 166 5390 4443 166 3166 166 4816 166 166 166
+166 3130 5963 1788 2129 1837 4100 6128 166 4586 5945 4772 166 5741 3151 3247
+5645 4507 5833 3904 6013 2506 3050 4175 1705 3019 166 5942 166 2418 3430 2230
+5745 166 2093 166 166 166 166 4666 3246 192 2010 4003 3533 5851 166 3621 3684
+3066 166 166 166 5073 3856 166 166 2224 166 2637 4270 166 166 5679 166 5792
+5850 166 2589 3060 2196 3476 3150 2025 166 166 166 2657 166 3685 3790 5587 2817
+3692 166 166 166 2359 2260 5896 2158 119 2816 5753 166 2739 5772 166 2919 2147
+1985 4271 4838 4991 166 166 166 5244 166 319 166 166 2779 4732 4994 5424 166
+166 3968 3049 3393 4473 4959 5967 5864 5170 4209 166 4810 4815 4205 2339 5023
+2279 5050 166 5837 132 166 166 166 2247 21 4775 166 166 5286 166 4170 4099 4803
+5767 166 166 166 5811 2240 5699 2499 166 4802 166 5785 166 166 166 3181 3435
+166 3339 166 5669 3865 2249 5002 166 4694 5461 4753 166 3157 166 1960 166 166
+166 2440 166 5818 5534 2439 1717 166 3789 2959 166 2943 166 2576 166 2002 2007
+1819 3256 4402 5311 3832 160 166 166 2803 166 3264 166 5863 166 2017 166 2798
+166 166 166 166 5607 4965 166 166 166 4537 4378 5944 3494 5457 5602 1942 5900
+5780 4411 5147 166 4966 2115 155 2827 1980 5063 166 285 5912 3304 2963 5179
+3220 166 166 166 2190 3708 5476 1944 2366 3893 166 166 166 3759 166 5434 2740
+1707 4244 5426 166 166 166 3155 166 4285 166 166 166 166 5721 166 3833 6001 301
+166 166 2574 186 2724 166 1873 3667 166 5216 166 2935 2100 4987 166 2284 166
+166 2911 3828 4009 166 2065 166 5496 6130 5563 4387 166 3771 3469 2989 2222
+4577 3965 4296 2975 3813 3240 166 4780 4481 3387 2338 166 6183 166 166 166 166
+166 2675 1761 2600 5167 3170 4773 2165 5166 166 2223 4642 166 166 4540 166 166
+166 3897 166 2483 1809 5477 3844 4067 2508 2275 166 166 166 166 166 3497 5458
+166 249 2956 166 4651 166 283 166 166 4955 4062 2315 2304 3261 2361 4791 4389
+1997 166 3455 166 166 166 166 166 166 4746 5695 5296 105 1841 3368 166 166 166
+5228 166 3496 4423 2024 3907 4774 166 166 166 166 166 2294 2193 166 166 166 166
+166 166 166 166 4393 166 166 2127 166 4573 166 5350 166 5016 3372 166 5653 166
+5972 4719 166 166 166 166 166 5370 166 6142 166 166 3691 2828 166 2601 166 2937
+2060 3654 3097 2341 5325 4568 4096 2776 166 2946 166 166 166 5843 1777 5295
+2837 4261 4397 5006 5808 4866 166 1713 5732 2954 166 166 27 166 4308 5629 2652
+2434 4474 166 4928 166 4727 3811 166 166 5234 166 6010 166 4911 166 4570 166
+6000 3450 5304 3919 166 166 4008 3942 166 272 2363 2064 3595 3505 166 166 3957
+1695 2452 4659 166 1792 166 131 5968 166 3731 3905 4115 166 166 2468 166 2727
+166 3526 4724 166 4388 3149 5539 5092 4440 6162 166 166 193 4429 2493 166 166
+3683 166 6029 166 277 166 166 166 5240 2408 166 309 2561 210 166 5200 166 166
+166 1930 5692 2697 166 166 166 3330 5331 3860 166 166 4335 166 50 3605 4289
+1763 166 166 166 166 3521 166 166 166 3668 166 166 166 166 166 3271 1656 166
+166 4782 166 2962 166 5907 166 3245 3375 2944 5933 166 166 5406 5655 3139 5423
+166 4359 5231 2548 166 3831 2858 5488 166 5824 166 166 166 3885 4372 166 166
+4024 166 4811 2970 166 4219 211 166 3471 166 166 166 166 3854 166 3358 2877 166
+166 5205 2804 166 166 166 4452 166 166 166 166 3776 166 166 3075 4208 166 5623
+1974 166 2647 166 3235 166 166 166 5211 166 166 4304 2206 166 4157 2182 166
+1816 2626 166 2893 2248 166 166 166 166 1983 5648 166 194 166 2106 4328 166
+4742 166 166 5572 2329 3314 166 6181 166 166 26 166 6026 166 166 2114 1669 4735
+166 166 4256 166 1861 166 5470 2317 166 4404 2482 166 5305 4415 5986 4949 5412
+166 1728 166 1898 166 166 4909 1989 166 166 166 2836 2051 274 166 2799 166 5865
+1663 4705 5121 2555 166 4316 4287 1880 1825 166 3689 166 1733 5012 166 166 2237
+4471 1682 2910 166 5366 166 166 166 166 4532 166 2802 166 166 166 4057 2471 166
+2889 166 166 4026 5682 3091 166 1977 166 2901 6137 5658 88 2318 1965 166 5914
+166 166 4468 1822 166 6050 5956 2201 166 4644 2918 166 3703 166 166 3524 4220
+2913 4210 166 166 2090 166 1906 1911 166 166 3671 2370 166 2552 166 3763 2259
+1924 166 5940 166 166 166 3185 3821 4069 261 2381 3244 166 166 5715 166 2052
+5905 166 2403 166 3030 2199 166 3550 166 166 1846 166 166 95 166 289 3208 2559
+5195 5091 1654 166 1781 1892 166 4516 2629 166 1700 3067 166 166 166 2080 1680
+166 166 166 5700 166 1820 5491 166 4226 166 166 166 166 4653 166 3508 227 5364
+166 2098 166 299 166 5795 166 166 166 166 3690 4134 5517 4534 5042 4874 5798
+4234 166 166 166 166 3702 166 166 3638 3108 3850 166 166 166 16 166 1775 166
+4022 166 223 4095 166 5127 4266 166 189 166 166 5203 166 1805 3884 3778 166 166
+2146 4818 166 2848 3440 4506 5886 3006 218 166 2377 166 4091 5925 166 4320 166
+2701 3036 166 166 166 4715 166 3801 166 3161 166 2077 166 4254 3032 243 1814
+166 166 166 166 166 166 166 166 1835 166 4394 166 5769 4923 166 2917 166 166
+178 166 166 1723 166 5887 166 4956 2952 166 4665 3925 3443 3123 166 166 166 166
+166 166 5144 166 4288 2074 2192 5442 6043 1746 2016 5995 2203 166 5686 5659
+3193 166 4055 166 166 2233 3571 5809 5984 2323 166 166 1740 89 4356 6053 6106
+3282 4796 166 6116 6056 2353 2829 166 5807 2042 166 166 166 1670 5937 4465 5646
+166 5562 3008 166 2419 3736 166 4132 169 166 166 166 2402 166 166 1968 2398 166
+1684 1827 4551 2679 3875 166 5585 3835 2295 166 1991 1803 2992 166 166 5847
+2649 166 76 5415 166 2269 2397 5387 5337 4422 166 2672 4832 4617 166 166 166
+166 4552 166 4612 1750 166 1931 166 1691 2424 4194 6018 166 166 4458 4856 166
+2089 3814 166 2844 166 3592 166 4867 5128 166 2685 166 166 2616 1972 2617 3943
+4664 166 4999 166 166 145 3635 166 166 4851 166 3483 5039 166 3649 3924 166 166
+166 3105 4260 166 6098 166 3568 267 2456 3653 2096 166 166 166 3512 166 3405
+166 3504 166 166 166 4005 2144 1769 166 5474 1920 5554 215 2443 3351 166 5961
+166 166 166 166 242 2331 166 166 5931 166 166 5862 166 1710 166 166 166 3321
+166 4139 166 166 3515 2732 2510 5544 166 166 2783 166 166 166 4018 4649 5789
+166 166 166 166 166 2726 6074 166 166 166 5684 166 166 3395 166 3100 166 5763
+3757 1992 166 3198 2003 166 166 4675 166 1893 5621 166 2270 166 166 166 5421
+5590 5664 4045 166 3687 4406 2699 1811 167 4036 5384 166 166 4601 1823 4041 239
+1954 166 146 166 166 3077 5152 5814 1649 5681 166 5868 166 166 3792 4860 166
+5335 5110 1718 166 166 166 166 3718 3365 2826 166 166 5021 4783 166 5569 5812
+166 166 1876 166 3260 166 1789 5667 4224 166 166 4385 166 166 2620 166 4162
+2883 2143 5497 166 166 5316 5680 166 166 248 4050 166 6021 166 2898 4618 166
+166 166 166 166 5368 166 5378 1842 1914 3696 3962 166 4345 2581 1773 2109 166
+4371 166 166 3761 5277 5870 3146 166 166 166 5764 127 3058 4059 4718 166 5097
+5040 5351 3205 166 166 4996 2991 2014 166 5846 2558 2688 5595 4027 3347 2125
+5696 5608 166 166 3228 3745 5775 166 1757 4647 166 5977 3020 166 240 2565 166
+4459 166 3367 166 166 166 3104 166 166 166 166 166 166 259 5486 2846 166 166
+166 4778 2713 166 3955 5683 2682 2914 5898 166 166 166 4400 317 166 5185 3021
+5983 4332 3891 166 3095 5003 166 166 166 5367 166 279 1784 4019 2736 4905 2651
+5346 166 4841 166 5606 166 166 2806 166 5239 166 166 3237 5490 166 225 166 166
+2254 166 2742 4587 22 166 166 166 5555 166 108 2927 2218 166 2120 166 5452 4087
+4369 166 166 166 166 166 4583 4338 6035 2840 4365 3624 11 1770 166 4630 166
+3216 166 166 166 4638 4699 3535 2536 4627 166 166 5760 1935 166 166 5210 166
+2219 2484 4597 5193 4799 3706 166 166 166 166 3337 3113 5951 4294 166 4040 3200
+4217 5861 2767 3530 4499 2775 4121 134 5939 5880 5908 3869 166 166 3316 6095
+2441 3288 166 3751 4794 166 166 5803 6169 2356 6182 6135 6127 166 3018 166 1674
+166 166 4097 166 5923 287 5965 5129 166 4078 166 166 6114 6015 5990 3573 166
+4146 2681 90 6055 4864 166 166 6119 3284 6054 5456 5113 6125 166 6057 166 3292
+166 166 166 166 166 6185 5105 1760 166 166 166 2720 166 2695 5448 166 1936 166
+1807 3406 166 166 2161 1642 166 5030 166 2036 5451 3427 166 166 166 166 3797
+166 1627 166 4515 166 166 166 4241 166 166 166 2771 166 31 5197 2638 3035 166
+166 3914 166 166 4546 166 166 166 4253 3500 166 166 2526 166 2698 166 3726 2744
+137 166 166 2676 166 5594 166 166 166 4842 166 63 2888 3585 4798 166 5011 166
+5634 5464 166 166 5620 3894 4070 166 2730 166 166 1810 2503 5957 1721 6066 5188
+166 166 1890 4505 1771 5455 166 3132 3984 166 166 2811 1962 166 166 4872 106
+3898 3267 166 2085 166 4950 6040 4525 6044 5866 3613 2907 4615 2135 258 166
+1681 1941 4888 166 4859 6178 6174 4858 5209 1912 3340 166 4640 5706 166 2763
+3153 3951 166 5542 5596 5819 5330 5048 4037 166 6033 4625 3326 2013 5283 136
+3373 2154 166 166 166 4421 166 5438 2627 2266 2320 166 2588 4790 4290 166 4767
+5829 2925 5916 2133 166 }
--- /dev/null
+Aaron Schaefer
\ No newline at end of file
--- /dev/null
+USING: help.markup help.syntax strings ;
+IN: poker
+
+HELP: <hand>
+{ $values { "str" string } { "hand" "a new hand" } }
+{ $description "Creates a new poker hand containing the cards specified in " { $snippet "str" } "." }
+{ $examples
+ { $example "USING: kernel math.order poker prettyprint ;"
+ "\"AC KC QC JC TC\" \"7C 6D 5H 4S 2C\" [ <hand> ] bi@ <=> ." "+lt+" }
+ { $example "USING: kernel poker prettyprint ;"
+ "\"TC 9C 8C 7C 6C\" \"TH 9H 8H 7H 6H\" [ <hand> ] bi@ = ." "t" }
+}
+{ $notes "Cards may be specified in any order. Hands are directly comparable to each other on the basis of their computed value. Two hands are considered equal when they would tie in a game (despite being composed of different cards)." } ;
+
+HELP: >cards
+{ $values { "hand" "a hand" } { "str" string } }
+{ $description "Outputs a string representation of a hand's cards." }
+{ $examples
+ { $example "USING: poker prettyprint ;"
+ "\"AC KC QC JC TC\" <hand> >cards ." "\"AC KC QC JC TC\"" }
+} ;
+
+HELP: >value
+{ $values { "hand" "a hand" } { "str" string } }
+{ $description "Outputs a string representation of a hand's value." }
+{ $examples
+ { $example "USING: poker prettyprint ;"
+ "\"AC KC QC JC TC\" <hand> >value ." "\"Straight Flush\"" }
+}
+{ $notes "This should not be used as a basis for hand comparison." } ;
--- /dev/null
+USING: accessors poker poker.private tools.test math.order kernel ;
+IN: poker.tests
+
+[ 134236965 ] [ "KD" >ckf ] unit-test
+[ 529159 ] [ "5s" >ckf ] unit-test
+[ 33589533 ] [ "jc" >ckf ] unit-test
+
+[ 7462 ] [ "7C 5D 4H 3S 2C" <hand> value>> ] unit-test
+[ 1601 ] [ "KD QS JC TH 9S" <hand> value>> ] unit-test
+[ 11 ] [ "AC AD AH AS KC" <hand> value>> ] unit-test
+[ 9 ] [ "6C 5C 4C 3C 2C" <hand> value>> ] unit-test
+[ 1 ] [ "AC KC QC JC TC" <hand> value>> ] unit-test
+
+[ "High Card" ] [ "7C 5D 4H 3S 2C" <hand> >value ] unit-test
+[ "Straight" ] [ "KD QS JC TH 9S" <hand> >value ] unit-test
+[ "Four of a Kind" ] [ "AC AD AH AS KC" <hand> >value ] unit-test
+[ "Straight Flush" ] [ "6C 5C 4C 3C 2C" <hand> >value ] unit-test
+
+[ "6C 5C 4C 3C 2C" ] [ "6C 5C 4C 3C 2C" <hand> >cards ] unit-test
+
+[ +gt+ ] [ "7C 5D 4H 3S 2C" "KD QS JC TH 9S" [ <hand> ] bi@ <=> ] unit-test
+[ +lt+ ] [ "AC AD AH AS KC" "KD QS JC TH 9S" [ <hand> ] bi@ <=> ] unit-test
+[ +eq+ ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ <=> ] unit-test
+
+[ t ] [ "7C 5D 4H 3S 2C" "2C 3S 4H 5D 7C" [ <hand> ] bi@ = ] unit-test
+
+[ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ = ] unit-test
+[ f ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ eq? ] unit-test
--- /dev/null
+! Copyright (c) 2009 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors ascii binary-search combinators kernel locals math
+ math.bitwise math.order poker.arrays sequences splitting ;
+IN: poker
+
+! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with
+! the Senzee Perfect Hash Optimization:
+! http://www.suffecool.net/poker/evaluator.html
+! http://www.senzee5.com/2006/06/some-perfect-hash.html
+
+<PRIVATE
+
+! Bitfield Format for Card Values:
+
+! +-------------------------------------+
+! | xxxbbbbb bbbbbbbb ssssrrrr xxpppppp |
+! +-------------------------------------+
+! xxxAKQJT 98765432 CDHSrrrr xxpppppp
+! +-------------------------------------+
+! | 00001000 00000000 01001011 00100101 | King of Diamonds
+! | 00000000 00001000 00010011 00000111 | Five of Spades
+! | 00000010 00000000 10001001 00011101 | Jack of Clubs
+
+! p = prime number value of rank (deuce = 2, trey = 3, four = 5, ..., ace = 41)
+! r = rank of card (deuce = 0, trey = 1, four = 2, ..., ace = 12)
+! s = bit turned on depending on suit of card
+! b = bit turned on depending on rank of card
+! x = bit turned off, not used
+
+CONSTANT: CLUB 8
+CONSTANT: DIAMOND 4
+CONSTANT: HEART 2
+CONSTANT: SPADE 1
+
+CONSTANT: DEUCE 0
+CONSTANT: TREY 1
+CONSTANT: FOUR 2
+CONSTANT: FIVE 3
+CONSTANT: SIX 4
+CONSTANT: SEVEN 5
+CONSTANT: EIGHT 6
+CONSTANT: NINE 7
+CONSTANT: TEN 8
+CONSTANT: JACK 9
+CONSTANT: QUEEN 10
+CONSTANT: KING 11
+CONSTANT: ACE 12
+
+CONSTANT: STRAIGHT_FLUSH 1
+CONSTANT: FOUR_OF_A_KIND 2
+CONSTANT: FULL_HOUSE 3
+CONSTANT: FLUSH 4
+CONSTANT: STRAIGHT 5
+CONSTANT: THREE_OF_A_KIND 6
+CONSTANT: TWO_PAIR 7
+CONSTANT: ONE_PAIR 8
+CONSTANT: HIGH_CARD 9
+
+CONSTANT: RANK_STR { "2" "3" "4" "5" "6" "7" "8" "9" "T" "J" "Q" "K" "A" }
+
+CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
+ "Straight" "Three of a Kind" "Two Pair" "One Pair" "High Card" }
+
+: card-rank-prime ( rank -- n )
+ RANK_STR index { 2 3 5 7 11 13 17 19 23 29 31 37 41 } nth ;
+
+: card-rank ( rank -- n )
+ {
+ { "2" [ DEUCE ] }
+ { "3" [ TREY ] }
+ { "4" [ FOUR ] }
+ { "5" [ FIVE ] }
+ { "6" [ SIX ] }
+ { "7" [ SEVEN ] }
+ { "8" [ EIGHT ] }
+ { "9" [ NINE ] }
+ { "T" [ TEN ] }
+ { "J" [ JACK ] }
+ { "Q" [ QUEEN ] }
+ { "K" [ KING ] }
+ { "A" [ ACE ] }
+ } case ;
+
+: card-suit ( suit -- n )
+ {
+ { "C" [ CLUB ] }
+ { "D" [ DIAMOND ] }
+ { "H" [ HEART ] }
+ { "S" [ SPADE ] }
+ } case ;
+
+: card-rank-bit ( rank -- n )
+ RANK_STR index 1 swap shift ;
+
+: card-bitfield ( rank rank suit rank -- n )
+ {
+ { card-rank-bit 16 }
+ { card-suit 12 }
+ { card-rank 8 }
+ { card-rank-prime 0 }
+ } bitfield ;
+
+:: (>ckf) ( rank suit -- n )
+ rank rank suit rank card-bitfield ;
+
+: >ckf ( str -- n )
+ #! Cactus Kev Format
+ >upper 1 cut (>ckf) ;
+
+: flush? ( cards -- ? )
+ HEX: F000 [ bitand ] reduce 0 = not ;
+
+: rank-bits ( cards -- q )
+ 0 [ bitor ] reduce -16 shift ;
+
+: lookup ( cards table -- value )
+ [ rank-bits ] dip nth ;
+
+: unique5? ( cards -- ? )
+ unique5-table lookup 0 > ;
+
+: map-product ( seq quot -- n )
+ [ 1 ] 2dip [ dip * ] curry [ swap ] prepose each ; inline
+
+: prime-bits ( cards -- q )
+ [ HEX: FF bitand ] map-product ;
+
+: perfect-hash-find ( q -- value )
+ #! magic to convert a hand's unique identifying bits to the
+ #! proper index for fast lookup in a table of hand values
+ HEX: E91AAA35 +
+ dup -16 shift bitxor
+ dup 8 shift w+
+ dup -4 shift bitxor
+ [ -8 shift HEX: 1FF bitand adjustments-table nth ]
+ [ dup 2 shift w+ -19 shift ] bi
+ bitxor values-table nth ;
+
+: hand-value ( cards -- value )
+ {
+ { [ dup flush? ] [ flushes-table lookup ] }
+ { [ dup unique5? ] [ unique5-table lookup ] }
+ [ prime-bits perfect-hash-find ]
+ } cond ;
+
+: >card-rank ( card -- str )
+ -8 shift HEX: F bitand RANK_STR nth ;
+
+: >card-suit ( card -- str )
+ {
+ { [ dup 15 bit? ] [ drop "C" ] }
+ { [ dup 14 bit? ] [ drop "D" ] }
+ { [ dup 13 bit? ] [ drop "H" ] }
+ [ drop "S" ]
+ } cond ;
+
+: hand-rank ( hand -- rank )
+ value>> {
+ { [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card
+ { [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair
+ { [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two pair
+ { [ dup 1609 > ] [ drop THREE_OF_A_KIND ] } ! 858 three-kind
+ { [ dup 1599 > ] [ drop STRAIGHT ] } ! 10 straights
+ { [ dup 322 > ] [ drop FLUSH ] } ! 1277 flushes
+ { [ dup 166 > ] [ drop FULL_HOUSE ] } ! 156 full house
+ { [ dup 10 > ] [ drop FOUR_OF_A_KIND ] } ! 156 four-kind
+ [ drop STRAIGHT_FLUSH ] ! 10 straight-flushes
+ } cond ;
+
+PRIVATE>
+
+TUPLE: hand
+ { cards sequence }
+ { value integer } ;
+
+M: hand <=> [ value>> ] compare ;
+M: hand equal?
+ over hand? [ [ value>> ] bi@ = ] [ 2drop f ] if ;
+
+: <hand> ( str -- hand )
+ " " split [ >ckf ] map
+ dup hand-value hand boa ;
+
+: >cards ( hand -- str )
+ cards>> [
+ [ >card-rank ] [ >card-suit ] bi append
+ ] map " " join ;
+
+: >value ( hand -- str )
+ hand-rank VALUE_STR nth ;
--- /dev/null
+5-card poker hand evaluator
[ 233168 ] [ euler001 ] unit-test
[ 233168 ] [ euler001a ] unit-test
[ 233168 ] [ euler001b ] unit-test
+[ 233168 ] [ euler001c ] unit-test
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.ranges sequences project-euler.common ;
+USING: kernel math math.functions math.ranges sequences project-euler.common ;
IN: project-euler.001
! http://projecteuler.net/index.php?section=problems&id=1
! [ euler001b ] 100 ave-time
! 0 ms run / 0 ms GC ave time - 100 trials
+
+: euler001c ( -- answer )
+ 1000 [ { 3 5 } [ divisor? ] with any? ] filter sum ;
+
+! [ euler001c ] 100 ave-time
+! 0 ms ave run time - 0.06 SD (100 trials)
+
SOLUTION: euler001
! Copyright (c) 2007 Aaron Schaefer, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables kernel math math.ranges project-euler.common sequences
- sorting sets ;
+USING: hashtables kernel math math.functions math.ranges project-euler.common
+ sequences sorting sets ;
IN: project-euler.004
! http://projecteuler.net/index.php?section=problems&id=4
<PRIVATE
: source-004 ( -- seq )
- 100 999 [a,b] [ 10 mod 0 = not ] filter ;
+ 100 999 [a,b] [ 10 divisor? not ] filter ;
: max-palindrome ( seq -- palindrome )
natural-sort [ palindrome? ] find-last nip ;
! SOLUTION
! --------
-: nth-prime ( n -- n )
- 1- lprimes lnth ;
-
: euler007 ( -- answer )
10001 nth-prime ;
! Copyright (c) 2007 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit kernel make math math.ranges
-sequences project-euler.common ;
+USING: combinators.short-circuit kernel make math math.functions math.ranges
+ sequences project-euler.common ;
IN: project-euler.014
! http://projecteuler.net/index.php?section=problems&id=14
<PRIVATE
: worth-calculating? ( n -- ? )
- 1- 3 { [ mod 0 = ] [ / even? ] } 2&& ;
+ 1- 3 { [ divisor? ] [ / even? ] } 2&& ;
PRIVATE>
10 99 [a,b] dup cartesian-product [ first2 < ] filter ;
: safe? ( ax xb -- ? )
- [ 10 /mod ] bi@ -roll = rot zero? not and nip ;
+ [ 10 /mod ] bi@ [ = ] dip zero? not and nip ;
: ax/xb ( ax xb -- z/f )
2dup safe? [ [ 10 /mod ] bi@ 2nip / ] [ 2drop f ] if ;
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit kernel math math.combinatorics math.parser
- math.ranges project-euler.common sequences sets sorting ;
+USING: combinators.short-circuit kernel math math.functions math.combinatorics
+ math.parser math.ranges project-euler.common sequences sets sorting ;
IN: project-euler.043
! http://projecteuler.net/index.php?section=problems&id=43
<PRIVATE
: subseq-divisible? ( n index seq -- ? )
- [ 1- dup 3 + ] dip subseq 10 digits>integer swap mod zero? ;
+ [ 1- dup 3 + ] dip subseq 10 digits>integer swap divisor? ;
: interesting? ( seq -- ? )
{
--- /dev/null
+USING: project-euler.049 tools.test ;
+IN: project-euler.049.tests
+
+[ 296962999629 ] [ euler049 ] unit-test
--- /dev/null
+! Copyright (c) 2009 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays byte-arrays fry hints kernel math math.combinatorics
+ math.functions math.parser math.primes project-euler.common sequences sets ;
+IN: project-euler.049
+
+! http://projecteuler.net/index.php?section=problems&id=49
+
+! DESCRIPTION
+! -----------
+
+! The arithmetic sequence, 1487, 4817, 8147, in which each of the terms
+! increases by 3330, is unusual in two ways: (i) each of the three terms are
+! prime, and, (ii) each of the 4-digit numbers are permutations of one another.
+
+! There are no arithmetic sequences made up of three 1-, 2-, or 3-digit primes,
+! exhibiting this property, but there is one other 4-digit increasing sequence.
+
+! What 12-digit number do you form by concatenating the three terms in this
+! sequence?
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: count-digits ( n -- byte-array )
+ 10 <byte-array> [
+ '[ 10 /mod _ [ 1+ ] change-nth dup 0 > ] loop drop
+ ] keep ;
+
+HINTS: count-digits fixnum ;
+
+: permutations? ( n m -- ? )
+ [ count-digits ] bi@ = ;
+
+: collect-permutations ( seq -- seq )
+ [ V{ } clone ] [ dup ] bi* [
+ dupd '[ _ permutations? ] filter
+ [ diff ] keep pick push
+ ] each drop ;
+
+: potential-sequences ( -- seq )
+ 1000 9999 primes-between
+ collect-permutations [ length 3 >= ] filter ;
+
+: arithmetic-terms ( m n -- seq )
+ 2dup [ swap - ] keep + 3array ;
+
+: (find-unusual-terms) ( n seq -- seq/f )
+ [ [ arithmetic-terms ] with map ] keep
+ '[ _ [ peek ] dip member? ] find nip ;
+
+: find-unusual-terms ( seq -- seq/? )
+ unclip-slice over (find-unusual-terms) [
+ nip
+ ] [
+ dup length 3 >= [ find-unusual-terms ] [ drop f ] if
+ ] if* ;
+
+: 4digit-concat ( seq -- str )
+ 0 [ [ 10000 * ] dip + ] reduce ;
+
+PRIVATE>
+
+: euler049 ( -- answer )
+ potential-sequences [ find-unusual-terms ] map sift
+ [ { 1487 4817 8147 } = not ] find nip 4digit-concat ;
+
+! [ euler049 ] 100 ave-time
+! 206 ms ave run time - 10.25 SD (100 trials)
+
+SOLUTION: euler049
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit kernel math
- project-euler.common sequences sorting
- grouping ;
+USING: combinators.short-circuit kernel math math.functions
+ project-euler.common sequences sorting grouping ;
IN: project-euler.052
! http://projecteuler.net/index.php?section=problems&id=52
[ number>digits natural-sort ] map all-equal? ;
: candidate? ( n -- ? )
- { [ odd? ] [ 3 mod 0 = ] } 1&& ;
+ { [ odd? ] [ 3 divisor? ] } 1&& ;
: next-all-same ( x n -- n )
dup candidate? [
--- /dev/null
+USING: project-euler.054 tools.test ;
+IN: project-euler.054.tests
+
+[ 376 ] [ euler054 ] unit-test
--- /dev/null
+! Copyright (c) 2009 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays io.encodings.ascii io.files kernel math.order poker
+ project-euler.common sequences ;
+IN: project-euler.054
+
+! http://projecteuler.net/index.php?section=problems&id=54
+
+! DESCRIPTION
+! -----------
+
+! In the card game poker, a hand consists of five cards and are ranked, from
+! lowest to highest, in the following way:
+
+! * High Card: Highest value card.
+! * One Pair: Two cards of the same value.
+! * Two Pairs: Two different pairs.
+! * Three of a Kind: Three cards of the same value.
+! * Straight: All cards are consecutive values.
+! * Flush: All cards of the same suit.
+! * Full House: Three of a kind and a pair.
+! * Four of a Kind: Four cards of the same value.
+! * Straight Flush: All cards are consecutive values of same suit.
+! * Royal Flush: Ten, Jack, Queen, King, Ace, in same suit.
+
+! The cards are valued in the order:
+! 2, 3, 4, 5, 6, 7, 8, 9, 10, Jack, Queen, King, Ace.
+
+! If two players have the same ranked hands then the rank made up of the
+! highest value wins; for example, a pair of eights beats a pair of fives (see
+! example 1 below). But if two ranks tie, for example, both players have a pair
+! of queens, then highest cards in each hand are compared (see example 4
+! below); if the highest cards tie then the next highest cards are compared,
+! and so on.
+
+! Consider the following five hands dealt to two players:
+
+! Hand Player 1 Player 2 Winner
+! ---------------------------------------------------------
+! 1 5H 5C 6S 7S KD 2C 3S 8S 8D TD
+! Pair of Fives Pair of Eights Player 2
+
+! 2 5D 8C 9S JS AC 2C 5C 7D 8S QH
+! Highest card Ace Highest card Queen Player 1
+
+! 3 2D 9C AS AH AC 3D 6D 7D TD QD
+! Three Aces Flush with Diamonds Player 2
+
+! 4 4D 6S 9H QH QC 3D 6D 7H QD QS
+! Pair of Queens Pair of Queens
+! Highest card Nine Highest card Seven Player 1
+
+! 5 2H 2D 4C 4D 4S 3C 3D 3S 9S 9D
+! Full House Full House
+! With Three Fours With Three Threes Player 1
+
+! The file, poker.txt, contains one-thousand random hands dealt to two players.
+! Each line of the file contains ten cards (separated by a single space): the
+! first five are Player 1's cards and the last five are Player 2's cards. You
+! can assume that all hands are valid (no invalid characters or repeated
+! cards), each player's hand is in no specific order, and in each hand there is
+! a clear winner.
+
+! How many hands does Player 1 win?
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: source-054 ( -- seq )
+ "resource:extra/project-euler/054/poker.txt" ascii file-lines
+ [ [ 14 head-slice ] [ 14 tail-slice* ] bi 2array ] map ;
+
+PRIVATE>
+
+: euler054 ( -- answer )
+ source-054 [ [ <hand> ] map first2 before? ] count ;
+
+! [ euler054 ] 100 ave-time
+! 34 ms ave run time - 2.65 SD (100 trials)
+
+SOLUTION: euler054
--- /dev/null
+8C TS KC 9H 4S 7D 2S 5D 3S AC\r
+5C AD 5D AC 9C 7C 5H 8D TD KS\r
+3H 7H 6S KC JS QH TD JC 2D 8S\r
+TH 8H 5C QS TC 9H 4D JC KS JS\r
+7C 5H KC QH JD AS KH 4C AD 4S\r
+5H KS 9C 7D 9H 8D 3S 5D 5C AH\r
+6H 4H 5C 3H 2H 3S QH 5S 6S AS\r
+TD 8C 4H 7C TC KC 4C 3H 7S KS\r
+7C 9C 6D KD 3H 4C QS QC AC KH\r
+JC 6S 5H 2H 2D KD 9D 7C AS JS\r
+AD QH TH 9D 8H TS 6D 3S AS AC\r
+2H 4S 5C 5S TC KC JD 6C TS 3C\r
+QD AS 6H JS 2C 3D 9H KC 4H 8S\r
+KD 8S 9S 7C 2S 3S 6D 6S 4H KC\r
+3C 8C 2D 7D 4D 9S 4S QH 4H JD\r
+8C KC 7S TC 2D TS 8H QD AC 5C\r
+3D KH QD 6C 6S AD AS 8H 2H QS\r
+6S 8D 4C 8S 6C QH TC 6D 7D 9D\r
+2S 8D 8C 4C TS 9S 9D 9C AC 3D\r
+3C QS 2S 4H JH 3D 2D TD 8S 9H\r
+5H QS 8S 6D 3C 8C JD AS 7H 7D\r
+6H TD 9D AS JH 6C QC 9S KD JC\r
+AH 8S QS 4D TH AC TS 3C 3D 5C\r
+5S 4D JS 3D 8H 6C TS 3S AD 8C\r
+6D 7C 5D 5H 3S 5C JC 2H 5S 3D\r
+5H 6H 2S KS 3D 5D JD 7H JS 8H\r
+KH 4H AS JS QS QC TC 6D 7C KS\r
+3D QS TS 2H JS 4D AS 9S JC KD\r
+QD 5H 4D 5D KH 7H 3D JS KD 4H\r
+2C 9H 6H 5C 9D 6C JC 2D TH 9S\r
+7D 6D AS QD JH 4D JS 7C QS 5C\r
+3H KH QD AD 8C 8H 3S TH 9D 5S\r
+AH 9S 4D 9D 8S 4H JS 3C TC 8D\r
+2C KS 5H QD 3S TS 9H AH AD 8S\r
+5C 7H 5D KD 9H 4D 3D 2D KS AD\r
+KS KC 9S 6D 2C QH 9D 9H TS TC\r
+9C 6H 5D QH 4D AD 6D QC JS KH\r
+9S 3H 9D JD 5C 4D 9H AS TC QH\r
+2C 6D JC 9C 3C AD 9S KH 9D 7D\r
+KC 9C 7C JC JS KD 3H AS 3C 7D\r
+QD KH QS 2C 3S 8S 8H 9H 9C JC\r
+QH 8D 3C KC 4C 4H 6D AD 9H 9D\r
+3S KS QS 7H KH 7D 5H 5D JD AD\r
+2H 2C 6H TH TC 7D 8D 4H 8C AS\r
+4S 2H AC QC 3S 6D TH 4D 4C KH\r
+4D TC KS AS 7C 3C 6D 2D 9H 6C\r
+8C TD 5D QS 2C 7H 4C 9C 3H 9H\r
+5H JH TS 7S TD 6H AD QD 8H 8S\r
+5S AD 9C 8C 7C 8D 5H 9D 8S 2S\r
+4H KH KS 9S 2S KC 5S AD 4S 7D\r
+QS 9C QD 6H JS 5D AC 8D 2S AS\r
+KH AC JC 3S 9D 9S 3C 9C 5S JS\r
+AD 3C 3D KS 3S 5C 9C 8C TS 4S\r
+JH 8D 5D 6H KD QS QD 3D 6C KC\r
+8S JD 6C 3S 8C TC QC 3C QH JS\r
+KC JC 8H 2S 9H 9C JH 8S 8C 9S\r
+8S 2H QH 4D QC 9D KC AS TH 3C\r
+8S 6H TH 7C 2H 6S 3C 3H AS 7S\r
+QH 5S JS 4H 5H TS 8H AH AC JC\r
+9D 8H 2S 4S TC JC 3C 7H 3H 5C\r
+3D AD 3C 3S 4C QC AS 5D TH 8C\r
+6S 9D 4C JS KH AH TS JD 8H AD\r
+4C 6S 9D 7S AC 4D 3D 3S TC JD\r
+AD 7H 6H 4H JH KC TD TS 7D 6S\r
+8H JH TC 3S 8D 8C 9S 2C 5C 4D\r
+2C 9D KC QH TH QS JC 9C 4H TS\r
+QS 3C QD 8H KH 4H 8D TD 8S AC\r
+7C 3C TH 5S 8H 8C 9C JD TC KD\r
+QC TC JD TS 8C 3H 6H KD 7C TD\r
+JH QS KS 9C 6D 6S AS 9H KH 6H\r
+2H 4D AH 2D JH 6H TD 5D 4H JD\r
+KD 8C 9S JH QD JS 2C QS 5C 7C\r
+4S TC 7H 8D 2S 6H 7S 9C 7C KC\r
+8C 5D 7H 4S TD QC 8S JS 4H KS\r
+AD 8S JH 6D TD KD 7C 6C 2D 7D\r
+JC 6H 6S JS 4H QH 9H AH 4C 3C\r
+6H 5H AS 7C 7S 3D KH KC 5D 5C\r
+JC 3D TD AS 4D 6D 6S QH JD KS\r
+8C 7S 8S QH 2S JD 5C 7H AH QD\r
+8S 3C 6H 6C 2C 8D TD 7D 4C 4D\r
+5D QH KH 7C 2S 7H JS 6D QC QD\r
+AD 6C 6S 7D TH 6H 2H 8H KH 4H\r
+KS JS KD 5D 2D KH 7D 9C 8C 3D\r
+9C 6D QD 3C KS 3S 7S AH JD 2D\r
+AH QH AS JC 8S 8H 4C KC TH 7D\r
+JC 5H TD 7C 5D KD 4C AD 8H JS\r
+KC 2H AC AH 7D JH KH 5D 7S 6D\r
+9S 5S 9C 6H 8S TD JD 9H 6C AC\r
+7D 8S 6D TS KD 7H AC 5S 7C 5D\r
+AH QC JC 4C TC 8C 2H TS 2C 7D\r
+KD KC 6S 3D 7D 2S 8S 3H 5S 5C\r
+8S 5D 8H 4C 6H KC 3H 7C 5S KD\r
+JH 8C 3D 3C 6C KC TD 7H 7C 4C\r
+JC KC 6H TS QS TD KS 8H 8C 9S\r
+6C 5S 9C QH 7D AH KS KC 9S 2C\r
+4D 4S 8H TD 9C 3S 7D 9D AS TH\r
+6S 7D 3C 6H 5D KD 2C 5C 9D 9C\r
+2H KC 3D AD 3H QD QS 8D JC 4S\r
+8C 3H 9C 7C AD 5D JC 9D JS AS\r
+5D 9H 5C 7H 6S 6C QC JC QD 9S\r
+JC QS JH 2C 6S 9C QC 3D 4S TC\r
+4H 5S 8D 3D 4D 2S KC 2H JS 2C\r
+TD 3S TH KD 4D 7H JH JS KS AC\r
+7S 8C 9S 2D 8S 7D 5C AD 9D AS\r
+8C 7H 2S 6C TH 3H 4C 3S 8H AC\r
+KD 5H JC 8H JD 2D 4H TD JH 5C\r
+3D AS QH KS 7H JD 8S 5S 6D 5H\r
+9S 6S TC QS JC 5C 5D 9C TH 8C\r
+5H 3S JH 9H 2S 2C 6S 7S AS KS\r
+8C QD JC QS TC QC 4H AC KH 6C\r
+TC 5H 7D JH 4H 2H 8D JC KS 4D\r
+5S 9C KH KD 9H 5C TS 3D 7D 2D\r
+5H AS TC 4D 8C 2C TS 9D 3H 8D\r
+6H 8D 2D 9H JD 6C 4S 5H 5S 6D\r
+AD 9C JC 7D 6H 9S 6D JS 9H 3C\r
+AD JH TC QS 4C 5D 9S 7C 9C AH\r
+KD 6H 2H TH 8S QD KS 9D 9H AS\r
+4H 8H 8D 5H 6C AH 5S AS AD 8S\r
+QS 5D 4S 2H TD KS 5H AC 3H JC\r
+9C 7D QD KD AC 6D 5H QH 6H 5S\r
+KC AH QH 2H 7D QS 3H KS 7S JD\r
+6C 8S 3H 6D KS QD 5D 5C 8H TC\r
+9H 4D 4S 6S 9D KH QC 4H 6C JD\r
+TD 2D QH 4S 6H JH KD 3C QD 8C\r
+4S 6H 7C QD 9D AS AH 6S AD 3C\r
+2C KC TH 6H 8D AH 5C 6D 8S 5D\r
+TD TS 7C AD JC QD 9H 3C KC 7H\r
+5D 4D 5S 8H 4H 7D 3H JD KD 2D\r
+JH TD 6H QS 4S KD 5C 8S 7D 8H\r
+AC 3D AS 8C TD 7H KH 5D 6C JD\r
+9D KS 7C 6D QH TC JD KD AS KC\r
+JH 8S 5S 7S 7D AS 2D 3D AD 2H\r
+2H 5D AS 3C QD KC 6H 9H 9S 2C\r
+9D 5D TH 4C JH 3H 8D TC 8H 9H\r
+6H KD 2C TD 2H 6C 9D 2D JS 8C\r
+KD 7S 3C 7C AS QH TS AD 8C 2S\r
+QS 8H 6C JS 4C 9S QC AD TD TS\r
+2H 7C TS TC 8C 3C 9H 2D 6D JC\r
+TC 2H 8D JH KS 6D 3H TD TH 8H\r
+9D TD 9H QC 5D 6C 8H 8C KC TS\r
+2H 8C 3D AH 4D TH TC 7D 8H KC\r
+TS 5C 2D 8C 6S KH AH 5H 6H KC\r
+5S 5D AH TC 4C JD 8D 6H 8C 6C\r
+KC QD 3D 8H 2D JC 9H 4H AD 2S\r
+TD 6S 7D JS KD 4H QS 2S 3S 8C\r
+4C 9H JH TS 3S 4H QC 5S 9S 9C\r
+2C KD 9H JS 9S 3H JC TS 5D AC\r
+AS 2H 5D AD 5H JC 7S TD JS 4C\r
+2D 4S 8H 3D 7D 2C AD KD 9C TS\r
+7H QD JH 5H JS AC 3D TH 4C 8H\r
+6D KH KC QD 5C AD 7C 2D 4H AC\r
+3D 9D TC 8S QD 2C JC 4H JD AH\r
+6C TD 5S TC 8S AH 2C 5D AS AC\r
+TH 7S 3D AS 6C 4C 7H 7D 4H AH\r
+5C 2H KS 6H 7S 4H 5H 3D 3C 7H\r
+3C 9S AC 7S QH 2H 3D 6S 3S 3H\r
+2D 3H AS 2C 6H TC JS 6S 9C 6C\r
+QH KD QD 6D AC 6H KH 2C TS 8C\r
+8H 7D 3S 9H 5D 3H 4S QC 9S 5H\r
+2D 9D 7H 6H 3C 8S 5H 4D 3S 4S\r
+KD 9S 4S TC 7S QC 3S 8S 2H 7H\r
+TC 3D 8C 3H 6C 2H 6H KS KD 4D\r
+KC 3D 9S 3H JS 4S 8H 2D 6C 8S\r
+6H QS 6C TC QD 9H 7D 7C 5H 4D\r
+TD 9D 8D 6S 6C TC 5D TS JS 8H\r
+4H KC JD 9H TC 2C 6S 5H 8H AS\r
+JS 9C 5C 6S 9D JD 8H KC 4C 6D\r
+4D 8D 8S 6C 7C 6H 7H 8H 5C KC\r
+TC 3D JC 6D KS 9S 6H 7S 9C 2C\r
+6C 3S KD 5H TS 7D 9H 9S 6H KH\r
+3D QD 4C 6H TS AC 3S 5C 2H KD\r
+4C AS JS 9S 7C TS 7H 9H JC KS\r
+4H 8C JD 3H 6H AD 9S 4S 5S KS\r
+4C 2C 7D 3D AS 9C 2S QS KC 6C\r
+8S 5H 3D 2S AC 9D 6S 3S 4D TD\r
+QD TH 7S TS 3D AC 7H 6C 5D QC\r
+TC QD AD 9C QS 5C 8D KD 3D 3C\r
+9D 8H AS 3S 7C 8S JD 2D 8D KC\r
+4C TH AC QH JS 8D 7D 7S 9C KH\r
+9D 8D 4C JH 2C 2S QD KD TS 4H\r
+4D 6D 5D 2D JH 3S 8S 3H TC KH\r
+AD 4D 2C QS 8C KD JH JD AH 5C\r
+5C 6C 5H 2H JH 4H KS 7C TC 3H\r
+3C 4C QC 5D JH 9C QD KH 8D TC\r
+3H 9C JS 7H QH AS 7C 9H 5H JC\r
+2D 5S QD 4S 3C KC 6S 6C 5C 4C\r
+5D KH 2D TS 8S 9C AS 9S 7C 4C\r
+7C AH 8C 8D 5S KD QH QS JH 2C\r
+8C 9D AH 2H AC QC 5S 8H 7H 2C\r
+QD 9H 5S QS QC 9C 5H JC TH 4H\r
+6C 6S 3H 5H 3S 6H KS 8D AC 7S\r
+AC QH 7H 8C 4S KC 6C 3D 3S TC\r
+9D 3D JS TH AC 5H 3H 8S 3S TC\r
+QD KH JS KS 9S QC 8D AH 3C AC\r
+5H 6C KH 3S 9S JH 2D QD AS 8C\r
+6C 4D 7S 7H 5S JC 6S 9H 4H JH\r
+AH 5S 6H 9S AD 3S TH 2H 9D 8C\r
+4C 8D 9H 7C QC AD 4S 9C KC 5S\r
+9D 6H 4D TC 4C JH 2S 5D 3S AS\r
+2H 6C 7C KH 5C AD QS TH JD 8S\r
+3S 4S 7S AH AS KC JS 2S AD TH\r
+JS KC 2S 7D 8C 5C 9C TS 5H 9D\r
+7S 9S 4D TD JH JS KH 6H 5D 2C\r
+JD JS JC TH 2D 3D QD 8C AC 5H\r
+7S KH 5S 9D 5D TD 4S 6H 3C 2D\r
+4S 5D AC 8D 4D 7C AD AS AH 9C\r
+6S TH TS KS 2C QC AH AS 3C 4S\r
+2H 8C 3S JC 5C 7C 3H 3C KH JH\r
+7S 3H JC 5S 6H 4C 2S 4D KC 7H\r
+4D 7C 4H 9S 8S 6S AD TC 6C JC\r
+KH QS 3S TC 4C 8H 8S AC 3C TS\r
+QD QS TH 3C TS 7H 7D AH TD JC\r
+TD JD QC 4D 9S 7S TS AD 7D AC\r
+AH 7H 4S 6D 7C 2H 9D KS JC TD\r
+7C AH JD 4H 6D QS TS 2H 2C 5C\r
+TC KC 8C 9S 4C JS 3C JC 6S AH\r
+AS 7D QC 3D 5S JC JD 9D TD KH\r
+TH 3C 2S 6H AH AC 5H 5C 7S 8H\r
+QC 2D AC QD 2S 3S JD QS 6S 8H\r
+KC 4H 3C 9D JS 6H 3S 8S AS 8C\r
+7H KC 7D JD 2H JC QH 5S 3H QS\r
+9H TD 3S 8H 7S AC 5C 6C AH 7C\r
+8D 9H AH JD TD QS 7D 3S 9C 8S\r
+AH QH 3C JD KC 4S 5S 5D TD KS\r
+9H 7H 6S JH TH 4C 7C AD 5C 2D\r
+7C KD 5S TC 9D 6S 6C 5D 2S TH\r
+KC 9H 8D 5H 7H 4H QC 3D 7C AS\r
+6S 8S QC TD 4S 5C TH QS QD 2S\r
+8S 5H TH QC 9H 6S KC 7D 7C 5C\r
+7H KD AH 4D KH 5C 4S 2D KC QH\r
+6S 2C TD JC AS 4D 6C 8C 4H 5S\r
+JC TC JD 5S 6S 8D AS 9D AD 3S\r
+6D 6H 5D 5S TC 3D 7D QS 9D QD\r
+4S 6C 8S 3S 7S AD KS 2D 7D 7C\r
+KC QH JC AC QD 5D 8D QS 7H 7D\r
+JS AH 8S 5H 3D TD 3H 4S 6C JH\r
+4S QS 7D AS 9H JS KS 6D TC 5C\r
+2D 5C 6H TC 4D QH 3D 9H 8S 6C\r
+6D 7H TC TH 5S JD 5C 9C KS KD\r
+8D TD QH 6S 4S 6C 8S KC 5C TC\r
+5S 3D KS AC 4S 7D QD 4C TH 2S\r
+TS 8H 9S 6S 7S QH 3C AH 7H 8C\r
+4C 8C TS JS QC 3D 7D 5D 7S JH\r
+8S 7S 9D QC AC 7C 6D 2H JH KC\r
+JS KD 3C 6S 4S 7C AH QC KS 5H\r
+KS 6S 4H JD QS TC 8H KC 6H AS\r
+KH 7C TC 6S TD JC 5C 7D AH 3S\r
+3H 4C 4H TC TH 6S 7H 6D 9C QH\r
+7D 5H 4S 8C JS 4D 3D 8S QH KC\r
+3H 6S AD 7H 3S QC 8S 4S 7S JS\r
+3S JD KH TH 6H QS 9C 6C 2D QD\r
+4S QH 4D 5H KC 7D 6D 8D TH 5S\r
+TD AD 6S 7H KD KH 9H 5S KC JC\r
+3H QC AS TS 4S QD KS 9C 7S KC\r
+TS 6S QC 6C TH TC 9D 5C 5D KD\r
+JS 3S 4H KD 4C QD 6D 9S JC 9D\r
+8S JS 6D 4H JH 6H 6S 6C KS KH\r
+AC 7D 5D TC 9S KH 6S QD 6H AS\r
+AS 7H 6D QH 8D TH 2S KH 5C 5H\r
+4C 7C 3D QC TC 4S KH 8C 2D JS\r
+6H 5D 7S 5H 9C 9H JH 8S TH 7H\r
+AS JS 2S QD KH 8H 4S AC 8D 8S\r
+3H 4C TD KD 8C JC 5C QS 2D JD\r
+TS 7D 5D 6C 2C QS 2H 3C AH KS\r
+4S 7C 9C 7D JH 6C 5C 8H 9D QD\r
+2S TD 7S 6D 9C 9S QS KH QH 5C\r
+JC 6S 9C QH JH 8D 7S JS KH 2H\r
+8D 5H TH KC 4D 4S 3S 6S 3D QS\r
+2D JD 4C TD 7C 6D TH 7S JC AH\r
+QS 7S 4C TH 9D TS AD 4D 3H 6H\r
+2D 3H 7D JD 3D AS 2S 9C QC 8S\r
+4H 9H 9C 2C 7S JH KD 5C 5D 6H\r
+TC 9H 8H JC 3C 9S 8D KS AD KC\r
+TS 5H JD QS QH QC 8D 5D KH AH\r
+5D AS 8S 6S 4C AH QC QD TH 7H\r
+3H 4H 7D 6S 4S 9H AS 8H JS 9D\r
+JD 8C 2C 9D 7D 5H 5S 9S JC KD\r
+KD 9C 4S QD AH 7C AD 9D AC TD\r
+6S 4H 4S 9C 8D KS TC 9D JH 7C\r
+5S JC 5H 4S QH AC 2C JS 2S 9S\r
+8C 5H AS QD AD 5C 7D 8S QC TD\r
+JC 4C 8D 5C KH QS 4D 6H 2H 2C\r
+TH 4S 2D KC 3H QD AC 7H AD 9D\r
+KH QD AS 8H TH KC 8D 7S QH 8C\r
+JC 6C 7D 8C KH AD QS 2H 6S 2D\r
+JC KH 2D 7D JS QC 5H 4C 5D AD\r
+TS 3S AD 4S TD 2D TH 6S 9H JH\r
+9H 2D QS 2C 4S 3D KH AS AC 9D\r
+KH 6S 8H 4S KD 7D 9D TS QD QC\r
+JH 5H AH KS AS AD JC QC 5S KH\r
+5D 7D 6D KS KD 3D 7C 4D JD 3S\r
+AC JS 8D 5H 9C 3H 4H 4D TS 2C\r
+6H KS KH 9D 7C 2S 6S 8S 2H 3D\r
+6H AC JS 7S 3S TD 8H 3H 4H TH\r
+9H TC QC KC 5C KS 6H 4H AC 8S\r
+TC 7D QH 4S JC TS 6D 6C AC KH\r
+QH 7D 7C JH QS QD TH 3H 5D KS\r
+3D 5S 8D JS 4C 2C KS 7H 9C 4H\r
+5H 8S 4H TD 2C 3S QD QC 3H KC\r
+QC JS KD 9C AD 5S 9D 7D 7H TS\r
+8C JC KH 7C 7S 6C TS 2C QD TH\r
+5S 9D TH 3C 7S QH 8S 9C 2H 5H\r
+5D 9H 6H 2S JS KH 3H 7C 2H 5S\r
+JD 5D 5S 2C TC 2S 6S 6C 3C 8S\r
+4D KH 8H 4H 2D KS 3H 5C 2S 9H\r
+3S 2D TD 7H 8S 6H JD KC 9C 8D\r
+6S QD JH 7C 9H 5H 8S 8H TH TD\r
+QS 7S TD 7D TS JC KD 7C 3C 2C\r
+3C JD 8S 4H 2D 2S TD AS 4D AC\r
+AH KS 6C 4C 4S 7D 8C 9H 6H AS\r
+5S 3C 9S 2C QS KD 4D 4S AC 5D\r
+2D TS 2C JS KH QH 5D 8C AS KC\r
+KD 3H 6C TH 8S 7S KH 6H 9S AC\r
+6H 7S 6C QS AH 2S 2H 4H 5D 5H\r
+5H JC QD 2C 2S JD AS QC 6S 7D\r
+6C TC AS KD 8H 9D 2C 7D JH 9S\r
+2H 4C 6C AH 8S TD 3H TH 7C TS\r
+KD 4S TS 6C QH 8D 9D 9C AH 7D\r
+6D JS 5C QD QC 9C 5D 8C 2H KD\r
+3C QH JH AD 6S AH KC 8S 6D 6H\r
+3D 7C 4C 7S 5S 3S 6S 5H JC 3C\r
+QH 7C 5H 3C 3S 8C TS 4C KD 9C\r
+QD 3S 7S 5H 7H QH JC 7C 8C KD\r
+3C KD KH 2S 4C TS AC 6S 2C 7C\r
+2C KH 3C 4C 6H 4D 5H 5S 7S QD\r
+4D 7C 8S QD TS 9D KS 6H KD 3C\r
+QS 4D TS 7S 4C 3H QD 8D 9S TC\r
+TS QH AC 6S 3C 9H 9D QS 8S 6H\r
+3S 7S 5D 4S JS 2D 6C QH 6S TH\r
+4C 4H AS JS 5D 3D TS 9C AC 8S\r
+6S 9C 7C 3S 5C QS AD AS 6H 3C\r
+9S 8C 7H 3H 6S 7C AS 9H JD KH\r
+3D 3H 7S 4D 6C 7C AC 2H 9C TH\r
+4H 5S 3H AC TC TH 9C 9H 9S 8D\r
+8D 9H 5H 4D 6C 2H QD 6S 5D 3S\r
+4C 5C JD QS 4D 3H TH AC QH 8C\r
+QC 5S 3C 7H AD 4C KS 4H JD 6D\r
+QS AH 3H KS 9H 2S JS JH 5H 2H\r
+2H 5S TH 6S TS 3S KS 3C 5H JS\r
+2D 9S 7H 3D KC JH 6D 7D JS TD\r
+AC JS 8H 2C 8C JH JC 2D TH 7S\r
+5D 9S 8H 2H 3D TC AH JC KD 9C\r
+9D QD JC 2H 6D KH TS 9S QH TH\r
+2C 8D 4S JD 5H 3H TH TC 9C KC\r
+AS 3D 9H 7D 4D TH KH 2H 7S 3H\r
+4H 7S KS 2S JS TS 8S 2H QD 8D\r
+5S 6H JH KS 8H 2S QC AC 6S 3S\r
+JC AS AD QS 8H 6C KH 4C 4D QD\r
+2S 3D TS TD 9S KS 6S QS 5C 8D\r
+3C 6D 4S QC KC JH QD TH KH AD\r
+9H AH 4D KS 2S 8D JH JC 7C QS\r
+2D 6C TH 3C 8H QD QH 2S 3S KS\r
+6H 5D 9S 4C TS TD JS QD 9D JD\r
+5H 8H KH 8S KS 7C TD AD 4S KD\r
+2C 7C JC 5S AS 6C 7D 8S 5H 9C\r
+6S QD 9S TS KH QS 5S QH 3C KC\r
+7D 3H 3C KD 5C AS JH 7H 6H JD\r
+9D 5C 9H KC 8H KS 4S AD 4D 2S\r
+3S JD QD 8D 2S 7C 5S 6S 5H TS\r
+6D 9S KC TD 3S 6H QD JD 5C 8D\r
+5H 9D TS KD 8D 6H TD QC 4C 7D\r
+6D 4S JD 9D AH 9S AS TD 9H QD\r
+2D 5S 2H 9C 6H 9S TD QC 7D TC\r
+3S 2H KS TS 2C 9C 8S JS 9D 7D\r
+3C KC 6D 5D 6C 6H 8S AS 7S QS\r
+JH 9S 2H 8D 4C 8H 9H AD TH KH\r
+QC AS 2S JS 5C 6H KD 3H 7H 2C\r
+QD 8H 2S 8D 3S 6D AH 2C TC 5C\r
+JD JS TS 8S 3H 5D TD KC JC 6H\r
+6S QS TC 3H 5D AH JC 7C 7D 4H\r
+7C 5D 8H 9C 2H 9H JH KH 5S 2C\r
+9C 7H 6S TH 3S QC QD 4C AC JD\r
+2H 5D 9S 7D KC 3S QS 2D AS KH\r
+2S 4S 2H 7D 5C TD TH QH 9S 4D\r
+6D 3S TS 6H 4H KS 9D 8H 5S 2D\r
+9H KS 4H 3S 5C 5D KH 6H 6S JS\r
+KC AS 8C 4C JC KH QC TH QD AH\r
+6S KH 9S 2C 5H TC 3C 7H JC 4D\r
+JD 4S 6S 5S 8D 7H 7S 4D 4C 2H\r
+7H 9H 5D KH 9C 7C TS TC 7S 5H\r
+4C 8D QC TS 4S 9H 3D AD JS 7C\r
+8C QS 5C 5D 3H JS AH KC 4S 9D\r
+TS JD 8S QS TH JH KH 2D QD JS\r
+JD QC 5D 6S 9H 3S 2C 8H 9S TS\r
+2S 4C AD 7H JC 5C 2D 6D 4H 3D\r
+7S JS 2C 4H 8C AD QD 9C 3S TD\r
+JD TS 4C 6H 9H 7D QD 6D 3C AS\r
+AS 7C 4C 6S 5D 5S 5C JS QC 4S\r
+KD 6S 9S 7C 3C 5S 7D JH QD JS\r
+4S 7S JH 2C 8S 5D 7H 3D QH AD\r
+TD 6H 2H 8D 4H 2D 7C AD KH 5D\r
+TS 3S 5H 2C QD AH 2S 5C KH TD\r
+KC 4D 8C 5D AS 6C 2H 2S 9H 7C\r
+KD JS QC TS QS KH JH 2C 5D AD\r
+3S 5H KC 6C 9H 3H 2H AD 7D 7S\r
+7S JS JH KD 8S 7D 2S 9H 7C 2H\r
+9H 2D 8D QC 6S AD AS 8H 5H 6C\r
+2S 7H 6C 6D 7D 8C 5D 9D JC 3C\r
+7C 9C 7H JD 2H KD 3S KH AD 4S\r
+QH AS 9H 4D JD KS KD TS KH 5H\r
+4C 8H 5S 3S 3D 7D TD AD 7S KC\r
+JS 8S 5S JC 8H TH 9C 4D 5D KC\r
+7C 5S 9C QD 2C QH JS 5H 8D KH\r
+TD 2S KS 3D AD KC 7S TC 3C 5D\r
+4C 2S AD QS 6C 9S QD TH QH 5C\r
+8C AD QS 2D 2S KC JD KS 6C JC\r
+8D 4D JS 2H 5D QD 7S 7D QH TS\r
+6S 7H 3S 8C 8S 9D QS 8H 6C 9S\r
+4S TC 2S 5C QD 4D QS 6D TH 6S\r
+3S 5C 9D 6H 8D 4C 7D TC 7C TD\r
+AH 6S AS 7H 5S KD 3H 5H AC 4C\r
+8D 8S AH KS QS 2C AD 6H 7D 5D\r
+6H 9H 9S 2H QS 8S 9C 5D 2D KD\r
+TS QC 5S JH 7D 7S TH 9S 9H AC\r
+7H 3H 6S KC 4D 6D 5C 4S QD TS\r
+TD 2S 7C QD 3H JH 9D 4H 7S 7H\r
+KS 3D 4H 5H TC 2S AS 2D 6D 7D\r
+8H 3C 7H TD 3H AD KC TH 9C KH\r
+TC 4C 2C 9S 9D 9C 5C 2H JD 3C\r
+3H AC TS 5D AD 8D 6H QC 6S 8C\r
+2S TS 3S JD 7H 8S QH 4C 5S 8D\r
+AC 4S 6C 3C KH 3D 7C 2D 8S 2H\r
+4H 6C 8S TH 2H 4S 8H 9S 3H 7S\r
+7C 4C 9C 2C 5C AS 5D KD 4D QH\r
+9H 4H TS AS 7D 8D 5D 9S 8C 2H\r
+QC KD AC AD 2H 7S AS 3S 2D 9S\r
+2H QC 8H TC 6D QD QS 5D KH 3C\r
+TH JD QS 4C 2S 5S AD 7H 3S AS\r
+7H JS 3D 6C 3S 6D AS 9S AC QS\r
+9C TS AS 8C TC 8S 6H 9D 8D 6C\r
+4D JD 9C KC 7C 6D KS 3S 8C AS\r
+3H 6S TC 8D TS 3S KC 9S 7C AS\r
+8C QC 4H 4S 8S 6C 3S TC AH AC\r
+4D 7D 5C AS 2H 6S TS QC AD TC\r
+QD QC 8S 4S TH 3D AH TS JH 4H\r
+5C 2D 9S 2C 3H 3C 9D QD QH 7D\r
+KC 9H 6C KD 7S 3C 4D AS TC 2D\r
+3D JS 4D 9D KS 7D TH QC 3H 3C\r
+8D 5S 2H 9D 3H 8C 4C 4H 3C TH\r
+JC TH 4S 6S JD 2D 4D 6C 3D 4C\r
+TS 3S 2D 4H AC 2C 6S 2H JH 6H\r
+TD 8S AD TC AH AC JH 9S 6S 7S\r
+6C KC 4S JD 8D 9H 5S 7H QH AH\r
+KD 8D TS JH 5C 5H 3H AD AS JS\r
+2D 4H 3D 6C 8C 7S AD 5D 5C 8S\r
+TD 5D 7S 9C 4S 5H 6C 8C 4C 8S\r
+JS QH 9C AS 5C QS JC 3D QC 7C\r
+JC 9C KH JH QS QC 2C TS 3D AD\r
+5D JH AC 5C 9S TS 4C JD 8C KS\r
+KC AS 2D KH 9H 2C 5S 4D 3D 6H\r
+TH AH 2D 8S JC 3D 8C QH 7S 3S\r
+8H QD 4H JC AS KH KS 3C 9S 6D\r
+9S QH 7D 9C 4S AC 7H KH 4D KD\r
+AH AD TH 6D 9C 9S KD KS QH 4H\r
+QD 6H 9C 7C QS 6D 6S 9D 5S JH\r
+AH 8D 5H QD 2H JC KS 4H KH 5S\r
+5C 2S JS 8D 9C 8C 3D AS KC AH\r
+JD 9S 2H QS 8H 5S 8C TH 5C 4C\r
+QC QS 8C 2S 2C 3S 9C 4C KS KH\r
+2D 5D 8S AH AD TD 2C JS KS 8C\r
+TC 5S 5H 8H QC 9H 6H JD 4H 9S\r
+3C JH 4H 9H AH 4S 2H 4C 8D AC\r
+8S TH 4D 7D 6D QD QS 7S TC 7C\r
+KH 6D 2D JD 5H JS QD JH 4H 4S\r
+9C 7S JH 4S 3S TS QC 8C TC 4H\r
+QH 9D 4D JH QS 3S 2C 7C 6C 2D\r
+4H 9S JD 5C 5H AH 9D TS 2D 4C\r
+KS JH TS 5D 2D AH JS 7H AS 8D\r
+JS AH 8C AD KS 5S 8H 2C 6C TH\r
+2H 5D AD AC KS 3D 8H TS 6H QC\r
+6D 4H TS 9C 5H JS JH 6S JD 4C\r
+JH QH 4H 2C 6D 3C 5D 4C QS KC\r
+6H 4H 6C 7H 6S 2S 8S KH QC 8C\r
+3H 3D 5D KS 4H TD AD 3S 4D TS\r
+5S 7C 8S 7D 2C KS 7S 6C 8C JS\r
+5D 2H 3S 7C 5C QD 5H 6D 9C 9H\r
+JS 2S KD 9S 8D TD TS AC 8C 9D\r
+5H QD 2S AC 8C 9H KS 7C 4S 3C\r
+KH AS 3H 8S 9C JS QS 4S AD 4D\r
+AS 2S TD AD 4D 9H JC 4C 5H QS\r
+5D 7C 4H TC 2D 6C JS 4S KC 3S\r
+4C 2C 5D AC 9H 3D JD 8S QS QH\r
+2C 8S 6H 3C QH 6D TC KD AC AH\r
+QC 6C 3S QS 4S AC 8D 5C AD KH\r
+5S 4C AC KH AS QC 2C 5C 8D 9C\r
+8H JD 3C KH 8D 5C 9C QD QH 9D\r
+7H TS 2C 8C 4S TD JC 9C 5H QH\r
+JS 4S 2C 7C TH 6C AS KS 7S JD\r
+JH 7C 9H 7H TC 5H 3D 6D 5D 4D\r
+2C QD JH 2H 9D 5S 3D TD AD KS\r
+JD QH 3S 4D TH 7D 6S QS KS 4H\r
+TC KS 5S 8D 8H AD 2S 2D 4C JH\r
+5S JH TC 3S 2D QS 9D 4C KD 9S\r
+AC KH 3H AS 9D KC 9H QD 6C 6S\r
+9H 7S 3D 5C 7D KC TD 8H 4H 6S\r
+3C 7H 8H TC QD 4D 7S 6S QH 6C\r
+6D AD 4C QD 6C 5D 7D 9D KS TS\r
+JH 2H JD 9S 7S TS KH 8D 5D 8H\r
+2D 9S 4C 7D 9D 5H QD 6D AC 6S\r
+7S 6D JC QD JH 4C 6S QS 2H 7D\r
+8C TD JH KD 2H 5C QS 2C JS 7S\r
+TC 5H 4H JH QD 3S 5S 5D 8S KH\r
+KS KH 7C 2C 5D JH 6S 9C 6D JC\r
+5H AH JD 9C JS KC 2H 6H 4D 5S\r
+AS 3C TH QC 6H 9C 8S 8C TD 7C\r
+KC 2C QD 9C KH 4D 7S 3C TS 9H\r
+9C QC 2S TS 8C TD 9S QD 3S 3C\r
+4D 9D TH JH AH 6S 2S JD QH JS\r
+QD 9H 6C KD 7D 7H 5D 6S 8H AH\r
+8H 3C 4S 2H 5H QS QH 7S 4H AC\r
+QS 3C 7S 9S 4H 3S AH KS 9D 7C\r
+AD 5S 6S 2H 2D 5H TC 4S 3C 8C\r
+QH TS 6S 4D JS KS JH AS 8S 6D\r
+2C 8S 2S TD 5H AS TC TS 6C KC\r
+KC TS 8H 2H 3H 7C 4C 5S TH TD\r
+KD AD KH 7H 7S 5D 5H 5S 2D 9C\r
+AD 9S 3D 7S 8C QC 7C 9C KD KS\r
+3C QC 9S 8C 4D 5C AS QD 6C 2C\r
+2H KC 8S JD 7S AC 8D 5C 2S 4D\r
+9D QH 3D 2S TC 3S KS 3C 9H TD\r
+KD 6S AC 2C 7H 5H 3S 6C 6H 8C\r
+QH TC 8S 6S KH TH 4H 5D TS 4D\r
+8C JS 4H 6H 2C 2H 7D AC QD 3D\r
+QS KC 6S 2D 5S 4H TD 3H JH 4C\r
+7S 5H 7H 8H KH 6H QS TH KD 7D\r
+5H AD KD 7C KH 5S TD 6D 3C 6C\r
+8C 9C 5H JD 7C KC KH 7H 2H 3S\r
+7S 4H AD 4D 8S QS TH 3D 7H 5S\r
+8D TC KS KD 9S 6D AD JD 5C 2S\r
+7H 8H 6C QD 2H 6H 9D TC 9S 7C\r
+8D 6D 4C 7C 6C 3C TH KH JS JH\r
+5S 3S 8S JS 9H AS AD 8H 7S KD\r
+JH 7C 2C KC 5H AS AD 9C 9S JS\r
+AD AC 2C 6S QD 7C 3H TH KS KD\r
+9D JD 4H 8H 4C KH 7S TS 8C KC\r
+3S 5S 2H 7S 6H 7D KS 5C 6D AD\r
+5S 8C 9H QS 7H 7S 2H 6C 7D TD\r
+QS 5S TD AC 9D KC 3D TC 2D 4D\r
+TD 2H 7D JD QD 4C 7H 5D KC 3D\r
+4C 3H 8S KD QH 5S QC 9H TC 5H\r
+9C QD TH 5H TS 5C 9H AH QH 2C\r
+4D 6S 3C AC 6C 3D 2C 2H TD TH\r
+AC 9C 5D QC 4D AD 8D 6D 8C KC\r
+AD 3C 4H AC 8D 8H 7S 9S TD JC\r
+4H 9H QH JS 2D TH TD TC KD KS\r
+5S 6S 9S 8D TH AS KH 5H 5C 8S\r
+JD 2S 9S 6S 5S 8S 5D 7S 7H 9D\r
+5D 8C 4C 9D AD TS 2C 7D KD TC\r
+8S QS 4D KC 5C 8D 4S KH JD KD\r
+AS 5C AD QH 7D 2H 9S 7H 7C TC\r
+2S 8S JD KH 7S 6C 6D AD 5D QC\r
+9H 6H 3S 8C 8H AH TC 4H JS TD\r
+2C TS 4D 7H 2D QC 9C 5D TH 7C\r
+6C 8H QC 5D TS JH 5C 5H 9H 4S\r
+2D QC 7H AS JS 8S 2H 4C 4H 8D\r
+JS 6S AC KD 3D 3C 4S 7H TH KC\r
+QH KH 6S QS 5S 4H 3C QD 3S 3H\r
+7H AS KH 8C 4H 9C 5S 3D 6S TS\r
+9C 7C 3H 5S QD 2C 3D AD AC 5H\r
+JH TD 2D 4C TS 3H KH AD 3S 7S\r
+AS 4C 5H 4D 6S KD JC 3C 6H 2D\r
+3H 6S 8C 2D TH 4S AH QH AD 5H\r
+7C 2S 9H 7H KC 5C 6D 5S 3H JC\r
+3C TC 9C 4H QD TD JH 6D 9H 5S\r
+7C 6S 5C 5D 6C 4S 7H 9H 6H AH\r
+AD 2H 7D KC 2C 4C 2S 9S 7H 3S\r
+TH 4C 8S 6S 3S AD KS AS JH TD\r
+5C TD 4S 4D AD 6S 5D TC 9C 7D\r
+8H 3S 4D 4S 5S 6H 5C AC 3H 3D\r
+9H 3C AC 4S QS 8S 9D QH 5H 4D\r
+JC 6C 5H TS AC 9C JD 8C 7C QD\r
+8S 8H 9C JD 2D QC QH 6H 3C 8D\r
+KS JS 2H 6H 5H QH QS 3H 7C 6D\r
+TC 3H 4S 7H QC 2H 3S 8C JS KH\r
+AH 8H 5S 4C 9H JD 3H 7S JC AC\r
+3C 2D 4C 5S 6C 4S QS 3S JD 3D\r
+5H 2D TC AH KS 6D 7H AD 8C 6H\r
+6C 7S 3C JD 7C 8H KS KH AH 6D\r
+AH 7D 3H 8H 8S 7H QS 5H 9D 2D\r
+JD AC 4H 7S 8S 9S KS AS 9D QH\r
+7S 2C 8S 5S JH QS JC AH KD 4C\r
+AH 2S 9H 4H 8D TS TD 6H QH JD\r
+4H JC 3H QS 6D 7S 9C 8S 9D 8D\r
+5H TD 4S 9S 4C 8C 8D 7H 3H 3D\r
+QS KH 3S 2C 2S 3C 7S TD 4S QD\r
+7C TD 4D 5S KH AC AS 7H 4C 6C\r
+2S 5H 6D JD 9H QS 8S 2C 2H TD\r
+2S TS 6H 9H 7S 4H JC 4C 5D 5S\r
+2C 5H 7D 4H 3S QH JC JS 6D 8H\r
+4C QH 7C QD 3S AD TH 8S 5S TS\r
+9H TC 2S TD JC 7D 3S 3D TH QH\r
+7D 4C 8S 5C JH 8H 6S 3S KC 3H\r
+JC 3H KH TC QH TH 6H 2C AC 5H\r
+QS 2H 9D 2C AS 6S 6C 2S 8C 8S\r
+9H 7D QC TH 4H KD QS AC 7S 3C\r
+4D JH 6S 5S 8H KS 9S QC 3S AS\r
+JD 2D 6S 7S TC 9H KC 3H 7D KD\r
+2H KH 7C 4D 4S 3H JS QD 7D KC\r
+4C JC AS 9D 3C JS 6C 8H QD 4D\r
+AH JS 3S 6C 4C 3D JH 6D 9C 9H\r
+9H 2D 8C 7H 5S KS 6H 9C 2S TC\r
+6C 8C AD 7H 6H 3D KH AS 5D TH\r
+KS 8C 3S TS 8S 4D 5S 9S 6C 4H\r
+9H 4S 4H 5C 7D KC 2D 2H 9D JH\r
+5C JS TC 9D 9H 5H 7S KH JC 6S\r
+7C 9H 8H 4D JC KH JD 2H TD TC\r
+8H 6C 2H 2C KH 6H 9D QS QH 5H\r
+AC 7D 2S 3D QD JC 2D 8D JD JH\r
+2H JC 2D 7H 2C 3C 8D KD TD 4H\r
+3S 4H 6D 8D TS 3H TD 3D 6H TH\r
+JH JC 3S AC QH 9H 7H 8S QC 2C\r
+7H TD QS 4S 8S 9C 2S 5D 4D 2H\r
+3D TS 3H 2S QC 8H 6H KC JC KS\r
+5D JD 7D TC 8C 6C 9S 3D 8D AC\r
+8H 6H JH 6C 5D 8D 8S 4H AD 2C\r
+9D 4H 2D 2C 3S TS AS TC 3C 5D\r
+4D TH 5H KS QS 6C 4S 2H 3D AD\r
+5C KC 6H 2C 5S 3C 4D 2D 9H 9S\r
+JD 4C 3H TH QH 9H 5S AH 8S AC\r
+7D 9S 6S 2H TD 9C 4H 8H QS 4C\r
+3C 6H 5D 4H 8C 9C KC 6S QD QS\r
+3S 9H KD TC 2D JS 8C 6S 4H 4S\r
+2S 4C 8S QS 6H KH 3H TH 8C 5D\r
+2C KH 5S 3S 7S 7H 6C 9D QD 8D\r
+8H KS AC 2D KH TS 6C JS KC 7H\r
+9C KS 5C TD QC AH 6C 5H 9S 7C\r
+5D 4D 3H 4H 6S 7C 7S AH QD TD\r
+2H 7D QC 6S TC TS AH 7S 9D 3H\r
+TH 5H QD 9S KS 7S 7C 6H 8C TD\r
+TH 2D 4D QC 5C 7D JD AH 9C 4H\r
+4H 3H AH 8D 6H QC QH 9H 2H 2C\r
+2D AD 4C TS 6H 7S TH 4H QS TD\r
+3C KD 2H 3H QS JD TC QC 5D 8H\r
+KS JC QD TH 9S KD 8D 8C 2D 9C\r
+3C QD KD 6D 4D 8D AH AD QC 8S\r
+8H 3S 9D 2S 3H KS 6H 4C 7C KC\r
+TH 9S 5C 3D 7D 6H AC 7S 4D 2C\r
+5C 3D JD 4D 2D 6D 5H 9H 4C KH\r
+AS 7H TD 6C 2H 3D QD KS 4C 4S\r
+JC 3C AC 7C JD JS 8H 9S QC 5D\r
+JD 6S 5S 2H AS 8C 7D 5H JH 3D\r
+8D TC 5S 9S 8S 3H JC 5H 7S AS\r
+5C TD 3D 7D 4H 8D 7H 4D 5D JS\r
+QS 9C KS TD 2S 8S 5C 2H 4H AS\r
+TH 7S 4H 7D 3H JD KD 5D 2S KC\r
+JD 7H 4S 8H 4C JS 6H QH 5S 4H\r
+2C QS 8C 5S 3H QC 2S 6C QD AD\r
+8C 3D JD TC 4H 2H AD 5S AC 2S\r
+5D 2C JS 2D AD 9D 3D 4C 4S JH\r
+8D 5H 5D 6H 7S 4D KS 9D TD JD\r
+3D 6D 9C 2S AS 7D 5S 5C 8H JD\r
+7C 8S 3S 6S 5H JD TC AD 7H 7S\r
+2S 9D TS 4D AC 8D 6C QD JD 3H\r
+9S KH 2C 3C AC 3D 5H 6H 8D 5D\r
+KS 3D 2D 6S AS 4C 2S 7C 7H KH\r
+AC 2H 3S JC 5C QH 4D 2D 5H 7S\r
+TS AS JD 8C 6H JC 8S 5S 2C 5D\r
+7S QH 7H 6C QC 8H 2D 7C JD 2S\r
+2C QD 2S 2H JC 9C 5D 2D JD JH\r
+7C 5C 9C 8S 7D 6D 8D 6C 9S JH\r
+2C AD 6S 5H 3S KS 7S 9D KH 4C\r
+7H 6C 2C 5C TH 9D 8D 3S QC AH\r
+5S KC 6H TC 5H 8S TH 6D 3C AH\r
+9C KD 4H AD TD 9S 4S 7D 6H 5D\r
+7H 5C 5H 6D AS 4C KD KH 4H 9D\r
+3C 2S 5C 6C JD QS 2H 9D 7D 3H\r
+AC 2S 6S 7S JS QD 5C QS 6H AD\r
+5H TH QC 7H TC 3S 7C 6D KC 3D\r
+4H 3D QC 9S 8H 2C 3S JC KS 5C\r
+4S 6S 2C 6H 8S 3S 3D 9H 3H JS\r
+4S 8C 4D 2D 8H 9H 7D 9D AH TS\r
+9S 2C 9H 4C 8D AS 7D 3D 6D 5S\r
+6S 4C 7H 8C 3H 5H JC AH 9D 9C\r
+2S 7C 5S JD 8C 3S 3D 4D 7D 6S\r
+3C KC 4S 5D 7D 3D JD 7H 3H 4H\r
+9C 9H 4H 4D TH 6D QD 8S 9S 7S\r
+2H AC 8S 4S AD 8C 2C AH 7D TC\r
+TS 9H 3C AD KS TC 3D 8C 8H JD\r
+QC 8D 2C 3C 7D 7C JD 9H 9C 6C\r
+AH 6S JS JH 5D AS QC 2C JD TD\r
+9H KD 2H 5D 2D 3S 7D TC AH TS\r
+TD 8H AS 5D AH QC AC 6S TC 5H\r
+KS 4S 7H 4D 8D 9C TC 2H 6H 3H\r
+3H KD 4S QD QH 3D 8H 8C TD 7S\r
+8S JD TC AH JS QS 2D KH KS 4D\r
+3C AD JC KD JS KH 4S TH 9H 2C\r
+QC 5S JS 9S KS AS 7C QD 2S JD\r
+KC 5S QS 3S 2D AC 5D 9H 8H KS\r
+6H 9C TC AD 2C 6D 5S JD 6C 7C\r
+QS KH TD QD 2C 3H 8S 2S QC AH\r
+9D 9H JH TC QH 3C 2S JS 5C 7H\r
+6C 3S 3D 2S 4S QD 2D TH 5D 2C\r
+2D 6H 6D 2S JC QH AS 7H 4H KH\r
+5H 6S KS AD TC TS 7C AC 4S 4H\r
+AD 3C 4H QS 8C 9D KS 2H 2D 4D\r
+4S 9D 6C 6D 9C AC 8D 3H 7H KD\r
+JC AH 6C TS JD 6D AD 3S 5D QD\r
+JC JH JD 3S 7S 8S JS QC 3H 4S\r
+JD TH 5C 2C AD JS 7H 9S 2H 7S\r
+8D 3S JH 4D QC AS JD 2C KC 6H\r
+2C AC 5H KD 5S 7H QD JH AH 2D\r
+JC QH 8D 8S TC 5H 5C AH 8C 6C\r
+3H JS 8S QD JH 3C 4H 6D 5C 3S\r
+6D 4S 4C AH 5H 5S 3H JD 7C 8D\r
+8H AH 2H 3H JS 3C 7D QC 4H KD\r
+6S 2H KD 5H 8H 2D 3C 8S 7S QD\r
+2S 7S KC QC AH TC QS 6D 4C 8D\r
+5S 9H 2C 3S QD 7S 6C 2H 7C 9D\r
+3C 6C 5C 5S JD JC KS 3S 5D TS\r
+7C KS 6S 5S 2S 2D TC 2H 5H QS\r
+AS 7H 6S TS 5H 9S 9D 3C KD 2H\r
+4S JS QS 3S 4H 7C 2S AC 6S 9D\r
+8C JH 2H 5H 7C 5D QH QS KH QC\r
+3S TD 3H 7C KC 8D 5H 8S KH 8C\r
+4H KH JD TS 3C 7H AS QC JS 5S\r
+AH 9D 2C 8D 4D 2D 6H 6C KC 6S\r
+2S 6H 9D 3S 7H 4D KH 8H KD 3D\r
+9C TC AC JH KH 4D JD 5H TD 3S\r
+7S 4H 9D AS 4C 7D QS 9S 2S KH\r
+3S 8D 8S KS 8C JC 5C KH 2H 5D\r
+8S QH 2C 4D KC JS QC 9D AC 6H\r
+8S 8C 7C JS JD 6S 4C 9C AC 4S\r
+QH 5D 2C 7D JC 8S 2D JS JH 4C\r
+JS 4C 7S TS JH KC KH 5H QD 4S\r
+QD 8C 8D 2D 6S TD 9D AC QH 5S\r
+QH QC JS 3D 3C 5C 4H KH 8S 7H\r
+7C 2C 5S JC 8S 3H QC 5D 2H KC\r
+5S 8D KD 6H 4H QD QH 6D AH 3D\r
+7S KS 6C 2S 4D AC QS 5H TS JD\r
+7C 2D TC 5D QS AC JS QC 6C KC\r
+2C KS 4D 3H TS 8S AD 4H 7S 9S\r
+QD 9H QH 5H 4H 4D KH 3S JC AD\r
+4D AC KC 8D 6D 4C 2D KH 2C JD\r
+2C 9H 2D AH 3H 6D 9C 7D TC KS\r
+8C 3H KD 7C 5C 2S 4S 5H AS AH\r
+TH JD 4H KD 3H TC 5C 3S AC KH\r
+6D 7H AH 7S QC 6H 2D TD JD AS\r
+JH 5D 7H TC 9S 7D JC AS 5S KH\r
+2H 8C AD TH 6H QD KD 9H 6S 6C\r
+QH KC 9D 4D 3S JS JH 4H 2C 9H\r
+TC 7H KH 4H JC 7D 9S 3H QS 7S\r
+AD 7D JH 6C 7H 4H 3S 3H 4D QH\r
+JD 2H 5C AS 6C QC 4D 3C TC JH\r
+AC JD 3H 6H 4C JC AD 7D 7H 9H\r
+4H TC TS 2C 8C 6S KS 2H JD 9S\r
+4C 3H QS QC 9S 9H 6D KC 9D 9C\r
+5C AD 8C 2C QH TH QD JC 8D 8H\r
+QC 2C 2S QD 9C 4D 3S 8D JH QS\r
+9D 3S 2C 7S 7C JC TD 3C TC 9H\r
+3C TS 8H 5C 4C 2C 6S 8D 7C 4H\r
+KS 7H 2H TC 4H 2C 3S AS AH QS\r
+8C 2D 2H 2C 4S 4C 6S 7D 5S 3S\r
+TH QC 5D TD 3C QS KD KC KS AS\r
+4D AH KD 9H KS 5C 4C 6H JC 7S\r
+KC 4H 5C QS TC 2H JC 9S AH QH\r
+4S 9H 3H 5H 3C QD 2H QC JH 8H\r
+5D AS 7H 2C 3D JH 6H 4C 6S 7D\r
+9C JD 9H AH JS 8S QH 3H KS 8H\r
+3S AC QC TS 4D AD 3D AH 8S 9H\r
+7H 3H QS 9C 9S 5H JH JS AH AC\r
+8D 3C JD 2H AC 9C 7H 5S 4D 8H\r
+7C JH 9H 6C JS 9S 7H 8C 9D 4H\r
+2D AS 9S 6H 4D JS JH 9H AD QD\r
+6H 7S JH KH AH 7H TD 5S 6S 2C\r
+8H JH 6S 5H 5S 9D TC 4C QC 9S\r
+7D 2C KD 3H 5H AS QD 7H JS 4D\r
+TS QH 6C 8H TH 5H 3C 3H 9C 9D\r
+AD KH JS 5D 3H AS AC 9S 5C KC\r
+2C KH 8C JC QS 6D AH 2D KC TC\r
+9D 3H 2S 7C 4D 6D KH KS 8D 7D\r
+9H 2S TC JH AC QC 3H 5S 3S 8H\r
+3S AS KD 8H 4C 3H 7C JH QH TS\r
+7S 6D 7H 9D JH 4C 3D 3S 6C AS\r
+4S 2H 2C 4C 8S 5H KC 8C QC QD\r
+3H 3S 6C QS QC 2D 6S 5D 2C 9D\r
+2H 8D JH 2S 3H 2D 6C 5C 7S AD\r
+9H JS 5D QH 8S TS 2H 7S 6S AD\r
+6D QC 9S 7H 5H 5C 7D KC JD 4H\r
+QC 5S 9H 9C 4D 6S KS 2S 4C 7C\r
+9H 7C 4H 8D 3S 6H 5C 8H JS 7S\r
+2D 6H JS TD 4H 4D JC TH 5H KC\r
+AC 7C 8D TH 3H 9S 2D 4C KC 4D\r
+KD QS 9C 7S 3D KS AD TS 4C 4H\r
+QH 9C 8H 2S 7D KS 7H 5D KD 4C\r
+9C 2S 2H JC 6S 6C TC QC JH 5C\r
+7S AC 8H KC 8S 6H QS JC 3D 6S\r
+JS 2D JH 8C 4S 6H 8H 6D 5D AD\r
+6H 7D 2S 4H 9H 7C AS AC 8H 5S\r
+3C JS 4S 6D 5H 2S QH 6S 9C 2C\r
+3D 5S 6S 9S 4C QS 8D QD 8S TC\r
+9C 3D AH 9H 5S 2C 7D AD JC 3S\r
+7H TC AS 3C 6S 6D 7S KH KC 9H\r
+3S TC 8H 6S 5H JH 8C 7D AC 2S\r
+QD 9D 9C 3S JC 8C KS 8H 5D 4D\r
+JS AH JD 6D 9D 8C 9H 9S 8H 3H\r
+2D 6S 4C 4D 8S AD 4S TC AH 9H\r
+TS AC QC TH KC 6D 4H 7S 8C 2H\r
+3C QD JS 9D 5S JC AH 2H TS 9H\r
+3H 4D QH 5D 9C 5H 7D 4S JC 3S\r
+8S TH 3H 7C 2H JD JS TS AC 8D\r
+9C 2H TD KC JD 2S 8C 5S AD 2C\r
+3D KD 7C 5H 4D QH QD TC 6H 7D\r
+7H 2C KC 5S KD 6H AH QC 7S QH\r
+6H 5C AC 5H 2C 9C 2D 7C TD 2S\r
+4D 9D AH 3D 7C JD 4H 8C 4C KS\r
+TH 3C JS QH 8H 4C AS 3D QS QC\r
+4D 7S 5H JH 6D 7D 6H JS KH 3C\r
+QD 8S 7D 2H 2C 7C JC 2S 5H 8C\r
+QH 8S 9D TC 2H AD 7C 8D QD 6S\r
+3S 7C AD 9H 2H 9S JD TS 4C 2D\r
+3S AS 4H QC 2C 8H 8S 7S TD TC\r
+JH TH TD 3S 4D 4H 5S 5D QS 2C\r
+8C QD QH TC 6D 4S 9S 9D 4H QC\r
+8C JS 9D 6H JD 3H AD 6S TD QC\r
+KC 8S 3D 7C TD 7D 8D 9H 4S 3S\r
+6C 4S 3D 9D KD TC KC KS AC 5S\r
+7C 6S QH 3D JS KD 6H 6D 2D 8C\r
+JD 2S 5S 4H 8S AC 2D 6S TS 5C\r
+5H 8C 5S 3C 4S 3D 7C 8D AS 3H\r
+AS TS 7C 3H AD 7D JC QS 6C 6H\r
+3S 9S 4C AC QH 5H 5D 9H TS 4H\r
+6C 5C 7H 7S TD AD JD 5S 2H 2S\r
+7D 6C KC 3S JD 8D 8S TS QS KH\r
+8S QS 8D 6C TH AC AH 2C 8H 9S\r
+7H TD KH QH 8S 3D 4D AH JD AS\r
+TS 3D 2H JC 2S JH KH 6C QC JS\r
+KC TH 2D 6H 7S 2S TC 8C 9D QS\r
+3C 9D 6S KH 8H 6D 5D TH 2C 2H\r
+6H TC 7D AD 4D 8S TS 9H TD 7S\r
+JS 6D JD JC 2H AC 6C 3D KH 8D\r
+KH JD 9S 5D 4H 4C 3H 7S QS 5C\r
+4H JD 5D 3S 3C 4D KH QH QS 7S\r
+JD TS 8S QD AH 4C 6H 3S 5S 2C\r
+QS 3D JD AS 8D TH 7C 6S QC KS\r
+7S 2H 8C QC 7H AC 6D 2D TH KH\r
+5S 6C 7H KH 7D AH 8C 5C 7S 3D\r
+3C KD AD 7D 6C 4D KS 2D 8C 4S\r
+7C 8D 5S 2D 2S AH AD 2C 9D TD\r
+3C AD 4S KS JH 7C 5C 8C 9C TH\r
+AS TD 4D 7C JD 8C QH 3C 5H 9S\r
+3H 9C 8S 9S 6S QD KS AH 5H JH\r
+QC 9C 5S 4H 2H TD 7D AS 8C 9D\r
+8C 2C 9D KD TC 7S 3D KH QC 3C\r
+4D AS 4C QS 5S 9D 6S JD QH KS\r
+6D AH 6C 4C 5H TS 9H 7D 3D 5S\r
+QS JD 7C 8D 9C AC 3S 6S 6C KH\r
+8H JH 5D 9S 6D AS 6S 3S QC 7H\r
+QD AD 5C JH 2H AH 4H AS KC 2C\r
+JH 9C 2C 6H 2D JS 5D 9H KC 6D\r
+7D 9D KD TH 3H AS 6S QC 6H AD\r
+JD 4H 7D KC 3H JS 3C TH 3D QS\r
+4C 3H 8C QD 5H 6H AS 8H AD JD\r
+TH 8S KD 5D QC 7D JS 5S 5H TS\r
+7D KC 9D QS 3H 3C 6D TS 7S AH\r
+7C 4H 7H AH QC AC 4D 5D 6D TH\r
+3C 4H 2S KD 8H 5H JH TC 6C JD\r
+4S 8C 3D 4H JS TD 7S JH QS KD\r
+7C QC KD 4D 7H 6S AD TD TC KH\r
+5H 9H KC 3H 4D 3D AD 6S QD 6H\r
+TH 7C 6H TS QH 5S 2C KC TD 6S\r
+7C 4D 5S JD JH 7D AC KD KH 4H\r
+7D 6C 8D 8H 5C JH 8S QD TH JD\r
+8D 7D 6C 7C 9D KD AS 5C QH JH\r
+9S 2C 8C 3C 4C KS JH 2D 8D 4H\r
+7S 6C JH KH 8H 3H 9D 2D AH 6D\r
+4D TC 9C 8D 7H TD KS TH KD 3C\r
+JD 9H 8D QD AS KD 9D 2C 2S 9C\r
+8D 3H 5C 7H KS 5H QH 2D 8C 9H\r
+2D TH 6D QD 6C KC 3H 3S AD 4C\r
+4H 3H JS 9D 3C TC 5H QH QC JC\r
+3D 5C 6H 3S 3C JC 5S 7S 2S QH\r
+AC 5C 8C 4D 5D 4H 2S QD 3C 3H\r
+2C TD AH 9C KD JS 6S QD 4C QC\r
+QS 8C 3S 4H TC JS 3H 7C JC AD\r
+5H 4D 9C KS JC TD 9S TS 8S 9H\r
+QD TS 7D AS AC 2C TD 6H 8H AH\r
+6S AD 8C 4S 9H 8D 9D KH 8S 3C\r
+QS 4D 2D 7S KH JS JC AD 4C 3C\r
+QS 9S 7H KC TD TH 5H JS AC JH\r
+6D AC 2S QS 7C AS KS 6S KH 5S\r
+6D 8H KH 3C QS 2H 5C 9C 9D 6C\r
+JS 2C 4C 6H 7D JC AC QD TD 3H\r
+4H QC 8H JD 4C KD KS 5C KC 7S\r
+6D 2D 3H 2S QD 5S 7H AS TH 6S\r
+AS 6D 8D 2C 8S TD 8H QD JC AH\r
+9C 9H 2D TD QH 2H 5C TC 3D 8H\r
+KC 8S 3D KH 2S TS TC 6S 4D JH\r
+9H 9D QS AC KC 6H 5D 4D 8D AH\r
+9S 5C QS 4H 7C 7D 2H 8S AD JS\r
+3D AC 9S AS 2C 2D 2H 3H JC KH\r
+7H QH KH JD TC KS 5S 8H 4C 8D\r
+2H 7H 3S 2S 5H QS 3C AS 9H KD\r
+AD 3D JD 6H 5S 9C 6D AC 9S 3S\r
+3D 5D 9C 2D AC 4S 2S AD 6C 6S\r
+QC 4C 2D 3H 6S KC QH QD 2H JH\r
+QC 3C 8S 4D 9S 2H 5C 8H QS QD\r
+6D KD 6S 7H 3S KH 2H 5C JC 6C\r
+3S 9S TC 6S 8H 2D AD 7S 8S TS\r
+3C 6H 9C 3H 5C JC 8H QH TD QD\r
+3C JS QD 5D TD 2C KH 9H TH AS\r
+9S TC JD 3D 5C 5H AD QH 9H KC\r
+TC 7H 4H 8H 3H TD 6S AC 7C 2S\r
+QS 9D 5D 3C JC KS 4D 6C JH 2S\r
+9S 6S 3C 7H TS 4C KD 6D 3D 9C\r
+2D 9H AH AC 7H 2S JH 3S 7C QC\r
+QD 9H 3C 2H AC AS 8S KD 8C KH\r
+2D 7S TD TH 6D JD 8D 4D 2H 5S\r
+8S QH KD JD QS JH 4D KC 5H 3S\r
+3C KH QC 6D 8H 3S AH 7D TD 2D\r
+5S 9H QH 4S 6S 6C 6D TS TH 7S\r
+6C 4C 6D QS JS 9C TS 3H 8D 8S\r
+JS 5C 7S AS 2C AH 2H AD 5S TC\r
+KD 6C 9C 9D TS 2S JC 4H 2C QD\r
+QS 9H TC 3H KC KS 4H 3C AD TH\r
+KH 9C 2H KD 9D TC 7S KC JH 2D\r
+7C 3S KC AS 8C 5D 9C 9S QH 3H\r
+2D 8C TD 4C 2H QC 5D TC 2C 7D\r
+KS 4D 6C QH TD KH 5D 7C AD 8D\r
+2S 9S 8S 4C 8C 3D 6H QD 7C 7H\r
+6C 8S QH 5H TS 5C 3C 4S 2S 2H\r
+8S 6S 2H JC 3S 3H 9D 8C 2S 7H\r
+QC 2C 8H 9C AC JD 4C 4H 6S 3S\r
+3H 3S 7D 4C 9S 5H 8H JC 3D TC\r
+QH 2S 2D 9S KD QD 9H AD 6D 9C\r
+8D 2D KS 9S JC 4C JD KC 4S TH\r
+KH TS 6D 4D 5C KD 5H AS 9H AD\r
+QD JS 7C 6D 5D 5C TH 5H QH QS\r
+9D QH KH 5H JH 4C 4D TC TH 6C\r
+KH AS TS 9D KD 9C 7S 4D 8H 5S\r
+KH AS 2S 7D 9D 4C TS TH AH 7C\r
+KS 4D AC 8S 9S 8D TH QH 9D 5C\r
+5D 5C 8C QS TC 4C 3D 3S 2C 8D\r
+9D KS 2D 3C KC 4S 8C KH 6C JC\r
+8H AH 6H 7D 7S QD 3C 4C 6C KC\r
+3H 2C QH 8H AS 7D 4C 8C 4H KC\r
+QD 5S 4H 2C TD AH JH QH 4C 8S\r
+3H QS 5S JS 8H 2S 9H 9C 3S 2C\r
+6H TS 7S JC QD AC TD KC 5S 3H\r
+QH AS QS 7D JC KC 2C 4C 5C 5S\r
+QH 3D AS JS 4H 8D 7H JC 2S 9C\r
+5D 4D 2S 4S 9D 9C 2D QS 8H 7H\r
+6D 7H 3H JS TS AC 2D JH 7C 8S\r
+JH 5H KC 3C TC 5S 9H 4C 8H 9D\r
+8S KC 5H 9H AD KS 9D KH 8D AH\r
+JC 2H 9H KS 6S 3H QC 5H AH 9C\r
+5C KH 5S AD 6C JC 9H QC 9C TD\r
+5S 5D JC QH 2D KS 8H QS 2H TS\r
+JH 5H 5S AH 7H 3C 8S AS TD KH\r
+6H 3D JD 2C 4C KC 7S AH 6C JH\r
+4C KS 9D AD 7S KC 7D 8H 3S 9C\r
+7H 5C 5H 3C 8H QC 3D KH 6D JC\r
+2D 4H 5D 7D QC AD AH 9H QH 8H\r
+KD 8C JS 9D 3S 3C 2H 5D 6D 2S\r
+8S 6S TS 3C 6H 8D 5S 3H TD 6C\r
+KS 3D JH 9C 7C 9S QS 5S 4H 6H\r
+7S 6S TH 4S KC KD 3S JC JH KS\r
+7C 3C 2S 6D QH 2C 7S 5H 8H AH\r
+KC 8D QD 6D KH 5C 7H 9D 3D 9C\r
+6H 2D 8S JS 9S 2S 6D KC 7C TC\r
+KD 9C JH 7H KC 8S 2S 7S 3D 6H\r
+4H 9H 2D 4C 8H 7H 5S 8S 2H 8D\r
+AD 7C 3C 7S 5S 4D 9H 3D JC KH\r
+5D AS 7D 6D 9C JC 4C QH QS KH\r
+KD JD 7D 3D QS QC 8S 6D JS QD\r
+6S 8C 5S QH TH 9H AS AC 2C JD\r
+QC KS QH 7S 3C 4C 5C KC 5D AH\r
+6C 4H 9D AH 2C 3H KD 3D TS 5C\r
+TD 8S QS AS JS 3H KD AC 4H KS\r
+7D 5D TS 9H 4H 4C 9C 2H 8C QC\r
+2C 7D 9H 4D KS 4C QH AD KD JS\r
+QD AD AH KH 9D JS 9H JC KD JD\r
+8S 3C 4S TS 7S 4D 5C 2S 6H 7C\r
+JS 7S 5C KD 6D QH 8S TD 2H 6S\r
+QH 6C TC 6H TD 4C 9D 2H QC 8H\r
+3D TS 4D 2H 6H 6S 2C 7H 8S 6C\r
+9H 9D JD JH 3S AH 2C 6S 3H 8S\r
+2C QS 8C 5S 3H 2S 7D 3C AD 4S\r
+5C QC QH AS TS 4S 6S 4C 5H JS\r
+JH 5C TD 4C 6H JS KD KH QS 4H\r
+TC KH JC 4D 9H 9D 8D KC 3C 8H\r
+2H TC 8S AD 9S 4H TS 7H 2C 5C\r
+4H 2S 6C 5S KS AH 9C 7C 8H KD\r
+TS QH TD QS 3C JH AH 2C 8D 7D\r
+5D KC 3H 5S AC 4S 7H QS 4C 2H\r
+3D 7D QC KH JH 6D 6C TD TH KD\r
+5S 8D TH 6C 9D 7D KH 8C 9S 6D\r
+JD QS 7S QC 2S QH JC 4S KS 8D\r
+7S 5S 9S JD KD 9C JC AD 2D 7C\r
+4S 5H AH JH 9C 5D TD 7C 2D 6S\r
+KC 6C 7H 6S 9C QD 5S 4H KS TD\r
+6S 8D KS 2D TH TD 9H JD TS 3S\r
+KH JS 4H 5D 9D TC TD QC JD TS\r
+QS QD AC AD 4C 6S 2D AS 3H KC\r
+4C 7C 3C TD QS 9C KC AS 8D AD\r
+KC 7H QC 6D 8H 6S 5S AH 7S 8C\r
+3S AD 9H JC 6D JD AS KH 6S JH\r
+AD 3D TS KS 7H JH 2D JS QD AC\r
+9C JD 7C 6D TC 6H 6C JC 3D 3S\r
+QC KC 3S JC KD 2C 8D AH QS TS\r
+AS KD 3D JD 8H 7C 8C 5C QD 6C\r
--- /dev/null
+USING: project-euler.058 tools.test ;
+
+{ 26241 } [ euler058 ] unit-test
--- /dev/null
+! Copyright (c) 2009 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry kernel math math.primes math.ranges project-euler.common sequences ;
+IN: project-euler.058
+
+! http://projecteuler.net/index.php?section=problems&id=58
+
+! DESCRIPTION
+! -----------
+
+! Starting with 1 and solveling anticlockwise in the following way, a square
+! solve with side length 7 is formed.
+
+! 37 36 35 34 33 32 31
+! 38 17 16 15 14 13 30
+! 39 18 5 4 3 12 29
+! 40 19 6 1 2 11 28
+! 41 20 7 8 9 10 27
+! 42 21 22 23 24 25 26
+! 43 44 45 46 47 48 49
+
+! It is interesting to note that the odd squares lie along the bottom right
+! diagonal, but what is more interesting is that 8 out of the 13 numbers lying
+! along both diagonals are prime; that is, a ratio of 8/13 ≈ 62%.
+
+! If one complete new layer is wrapped around the solve above, a square solve
+! with side length 9 will be formed. If this process is continued, what is the
+! side length of the square solve for which the ratio of primes along both
+! diagonals first falls below 10%?
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+CONSTANT: PERCENT_PRIME 0.1
+
+! The corners of a square of side length n are:
+! (n-2)² + 1(n-1)
+! (n-2)² + 2(n-1)
+! (n-2)² + 3(n-1)
+! (n-2)² + 4(n-1) = odd squares, no need to calculate
+
+: prime-corners ( n -- m )
+ 3 [1,b] swap '[ _ [ 1- * ] keep 2 - sq + prime? ] count ;
+
+: total-corners ( n -- m )
+ 1- 2 * ; foldable
+
+: ratio-below? ( count length -- ? )
+ total-corners 1+ / PERCENT_PRIME < ;
+
+: next-layer ( count length -- count' length' )
+ 2 + [ prime-corners + ] keep ;
+
+: solve ( count length -- length )
+ 2dup ratio-below? [ nip ] [ next-layer solve ] if ;
+
+PRIVATE>
+
+: euler058 ( -- answer )
+ 8 7 solve ;
+
+! [ euler058 ] 10 ave-time
+! 12974 ms ave run time - 284.46 SD (10 trials)
+
+SOLUTION: euler058
--- /dev/null
+USING: project-euler.063 tools.test ;
+
+{ 49 } [ euler063 ] unit-test
--- /dev/null
+! Copyright (c) 2009 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.functions math.ranges project-euler.common sequences ;
+IN: project-euler.063
+
+! http://projecteuler.net/index.php?section=problems&id=63
+
+! DESCRIPTION
+! -----------
+
+! The 5-digit number, 16807 = 7^5, is also a fifth power. Similarly, the
+! 9-digit number, 134217728 = 8^9, is a ninth power.
+
+! How many n-digit positive integers exist which are also an nth power?
+
+
+! SOLUTION
+! --------
+
+! Only have to check from 1 to 9 because 10^n already has too many digits.
+! In general, x^n has n digits when:
+
+! 10^(n-1) <= x^n < 10^n
+
+! ...take the left side of that equation, solve for n to see where they meet:
+
+! n = log(10) / [ log(10) - log(x) ]
+
+! Round down since we already know that particular value of n is no good.
+
+: euler063 ( -- answer )
+ 9 [1,b] [ log [ 10 log dup ] dip - /i ] sigma ;
+
+! [ euler063 ] 100 ave-time
+! 0 ms ave run time - 0.0 SD (100 trials)
+
+SOLUTION: euler063
--- /dev/null
+USING: project-euler.069 tools.test ;
+
+{ 510510 } [ euler069 ] unit-test
+{ 510510 } [ euler069a ] unit-test
--- /dev/null
+! Copyright (c) 2009 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators fry kernel math math.primes math.primes.factors math.ranges
+ project-euler.common sequences ;
+IN: project-euler.069
+
+! http://projecteuler.net/index.php?section=problems&id=69
+
+! DESCRIPTION
+! -----------
+
+! Euler's Totient function, φ(n) [sometimes called the phi function], is used
+! to determine the number of numbers less than n which are relatively prime to
+! n. For example, as 1, 2, 4, 5, 7, and 8, are all less than nine and
+! relatively prime to nine, φ(9)=6.
+
+! +----+------------------+------+-----------+
+! | n | Relatively Prime | φ(n) | n / φ(n) |
+! +----+------------------+------+-----------+
+! | 2 | 1 | 1 | 2 |
+! | 3 | 1,2 | 2 | 1.5 |
+! | 4 | 1,3 | 2 | 2 |
+! | 5 | 1,2,3,4 | 4 | 1.25 |
+! | 6 | 1,5 | 2 | 3 |
+! | 7 | 1,2,3,4,5,6 | 6 | 1.1666... |
+! | 8 | 1,3,5,7 | 4 | 2 |
+! | 9 | 1,2,4,5,7,8 | 6 | 1.5 |
+! | 10 | 1,3,7,9 | 4 | 2.5 |
+! +----+------------------+------+-----------+
+
+! It can be seen that n = 6 produces a maximum n / φ(n) for n ≤ 10.
+
+! Find the value of n ≤ 1,000,000 for which n / φ(n) is a maximum.
+
+
+! SOLUTION
+! --------
+
+! Brute force
+
+<PRIVATE
+
+: totient-ratio ( n -- m )
+ dup totient / ;
+
+PRIVATE>
+
+: euler069 ( -- answer )
+ 2 1000000 [a,b] [ totient-ratio ] map
+ [ supremum ] keep index 2 + ;
+
+! [ euler069 ] 10 ave-time
+! 25210 ms ave run time - 115.37 SD (10 trials)
+
+
+! ALTERNATE SOLUTIONS
+! -------------------
+
+! In order to obtain maximum n / φ(n), φ(n) needs to be low and n needs to be
+! high. Hence we need a number that has the most factors. A number with the
+! most unique factors would have fewer relatively prime.
+
+<PRIVATE
+
+: primorial ( n -- m )
+ {
+ { [ dup 0 = ] [ drop V{ 1 } ] }
+ { [ dup 1 = ] [ drop V{ 2 } ] }
+ [ nth-prime primes-upto ]
+ } cond product ;
+
+: (primorial-upto) ( count limit -- m )
+ '[ dup primorial _ <= ] [ 1+ dup primorial ] produce
+ nip penultimate ;
+
+: primorial-upto ( limit -- m )
+ 1 swap (primorial-upto) ;
+
+PRIVATE>
+
+: euler069a ( -- answer )
+ 1000000 primorial-upto ;
+
+! [ euler069a ] 100 ave-time
+! 0 ms ave run time - 0.01 SD (100 trials)
+
+SOLUTION: euler069a
! 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 ;
-! Copyright (c) 2007-2008 Aaron Schaefer.
+! Copyright (c) 2007-2009 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 math.ratios
- sequences sorting strings unicode.case parser accessors vocabs.parser
- namespaces vocabs words quotations prettyprint ;
+USING: accessors arrays kernel lists make math math.functions math.matrices
+ math.miller-rabin math.order math.parser math.primes.factors
+ math.primes.lists math.ranges math.ratios namespaces parser prettyprint
+ quotations sequences sorting strings unicode.case vocabs vocabs.parser
+ words ;
IN: project-euler.common
! A collection of words used by more than one Project Euler solution
! log10 - #25, #134
! max-path - #18, #67
! mediant - #71, #73
+! nth-prime - #7, #69
! nth-triangle - #12, #42
! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92
! palindrome? - #4, #36, #55
! pandigital? - #32, #38
! pentagonal? - #44, #45
+! penultimate - #69, #71
! propagate-all - #18, #67
! sum-proper-divisors - #21
! tau* - #12
: (sum-divisors) ( n -- sum )
dup sqrt >integer [1,b] [
- [ 2dup mod 0 = [ 2dup / + , ] [ drop ] if ] each
+ [ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each
dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
] { } make sum ;
>lower [ CHAR: a - 1+ ] sigma ;
: cartesian-product ( seq1 seq2 -- seq1xseq2 )
- swap [ swap [ 2array ] with map ] with map concat ;
+ [ [ 2array ] with map ] curry map concat ;
: log10 ( m -- n )
log 10 log / ;
: number>digits ( n -- seq )
[ dup 0 = not ] [ 10 /mod ] produce reverse nip ;
+: number-length ( n -- m )
+ log10 floor 1+ >integer ;
+
+: nth-prime ( n -- n )
+ 1- lprimes lnth ;
+
: nth-triangle ( n -- n )
dup 1+ * 2 / ;
: pentagonal? ( n -- ? )
dup 0 > [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ;
+: penultimate ( seq -- elt )
+ dup length 2 - swap nth ;
+
! Not strictly needed, but it is nice to be able to dump the triangle after the
! propagation
: propagate-all ( triangle -- new-triangle )
factor-2s dup [ 1+ ]
[ perfect-square? -1 0 ? ]
[ dup sqrt >fixnum [1,b] ] tri* [
- dupd mod 0 = [ [ 2 + ] dip ] when
+ dupd divisor? [ [ 2 + ] dip ] when
] each drop * ;
! These transforms are for generating primitive Pythagorean triples
[ drop in get vocab (>>main) ]
[ [ . ] swap prefix (( -- )) define-declared ]
2bi ;
-
-! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
+! Copyright (c) 2007-2009 Aaron Schaefer, Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: definitions io io.files io.pathnames kernel math math.parser
prettyprint project-euler.ave-time sequences vocabs vocabs.loader
project-euler.037 project-euler.038 project-euler.039 project-euler.040
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.057 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.099 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.203 project-euler.215 ;
+ project-euler.049 project-euler.052 project-euler.053 project-euler.054
+ project-euler.055 project-euler.056 project-euler.057 project-euler.058
+ project-euler.059 project-euler.063 project-euler.067 project-euler.069
+ project-euler.071 project-euler.073 project-euler.075 project-euler.076
+ project-euler.079 project-euler.092 project-euler.097 project-euler.099
+ 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.203 project-euler.215 ;
IN: project-euler
<PRIVATE
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: calendar io.encodings.utf8 io.files robots tools.test ;
+USING: calendar io.encodings.utf8 io.files robots tools.test
+urls ;
IN: robots.tests
[
-{ "http://www.chiplist.com/sitemap.txt" }
-{
- T{ rules
- { user-agents V{ "*" } }
- { allows V{ } }
- { disallows
- V{
- "/cgi-bin/"
- "/scripts/"
- "/ChipList2/scripts/"
- "/ChipList2/styles/"
- "/ads/"
- "/ChipList2/ads/"
- "/advertisements/"
- "/ChipList2/advertisements/"
- "/graphics/"
- "/ChipList2/graphics/"
+ { "http://www.chiplist.com/sitemap.txt" }
+ {
+ T{ rules
+ { user-agents V{ "*" } }
+ { allows V{ } }
+ { disallows
+ V{
+ URL" /cgi-bin/"
+ URL" /scripts/"
+ URL" /ChipList2/scripts/"
+ URL" /ChipList2/styles/"
+ URL" /ads/"
+ URL" /ChipList2/ads/"
+ URL" /advertisements/"
+ URL" /ChipList2/advertisements/"
+ URL" /graphics/"
+ URL" /ChipList2/graphics/"
+ }
}
- }
- { visit-time
- {
- T{ timestamp { hour 2 } }
- T{ timestamp { hour 5 } }
+ { visit-time
+ {
+ T{ timestamp { hour 2 } }
+ T{ timestamp { hour 5 } }
+ }
}
+ { request-rate 1 }
+ { crawl-delay 1 }
+ { unknowns H{ } }
}
- { request-rate 1 }
- { crawl-delay 1 }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "UbiCrawler" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "DOC" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "Zao" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "sitecheck.internetseer.com" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "Zealbot" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "MSIECrawler" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "SiteSnagger" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "WebStripper" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "WebCopier" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "Fetch" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "Offline Explorer" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "Teleport" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "TeleportPro" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "WebZIP" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "linko" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "HTTrack" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "Microsoft.URL.Control" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "Xenu" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "larbin" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "libwww" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "ZyBORG" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "Download Ninja" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "wget" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "grub-client" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "k2spider" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "NPBot" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "WebReaper" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents
- V{
- "abot"
- "ALeadSoftbot"
- "BeijingCrawler"
- "BilgiBot"
- "bot"
- "botlist"
- "BOTW Spider"
- "bumblebee"
- "Bumblebee"
- "BuzzRankingBot"
- "Charlotte"
- "Clushbot"
- "Crawler"
- "CydralSpider"
- "DataFountains"
- "DiamondBot"
- "Dulance bot"
- "DYNAMIC"
- "EARTHCOM.info"
- "EDI"
- "envolk"
- "Exabot"
- "Exabot-Images"
- "Exabot-Test"
- "exactseek-pagereaper"
- "Exalead NG"
- "FANGCrawl"
- "Feed::Find"
- "flatlandbot"
- "Gigabot"
- "GigabotSiteSearch"
- "GurujiBot"
- "Hatena Antenna"
- "Hatena Bookmark"
- "Hatena RSS"
- "HatenaScreenshot"
- "Helix"
- "HiddenMarket"
- "HyperEstraier"
- "iaskspider"
- "IIITBOT"
- "InfociousBot"
- "iVia"
- "iVia Page Fetcher"
- "Jetbot"
- "Kolinka Forum Search"
- "KRetrieve"
- "LetsCrawl.com"
- "Lincoln State Web Browser"
- "Links4US-Crawler"
- "LOOQ"
- "Lsearch/sondeur"
- "MapoftheInternet.com"
- "NationalDirectory"
- "NetCarta_WebMapper"
- "NewsGator"
- "NextGenSearchBot"
- "ng"
- "nicebot"
- "NP"
- "NPBot"
- "Nudelsalat"
- "Nutch"
- "OmniExplorer_Bot"
- "OpenIntelligenceData"
- "Oracle Enterprise Search"
- "Pajaczek"
- "panscient.com"
- "PeerFactor 404 crawler"
- "PeerFactor Crawler"
- "PlantyNet"
- "PlantyNet_WebRobot"
- "plinki"
- "PMAFind"
- "Pogodak!"
- "QuickFinder Crawler"
- "Radiation Retriever"
- "Reaper"
- "RedCarpet"
- "ScorpionBot"
- "Scrubby"
- "Scumbot"
- "searchbot"
- "Seeker.lookseek.com"
- "SeznamBot"
- "ShowXML"
- "snap.com"
- "snap.com beta crawler"
- "Snapbot"
- "SnapPreviewBot"
- "sohu"
- "SpankBot"
- "Speedy Spider"
- "Speedy_Spider"
- "SpeedySpider"
- "spider"
- "SquigglebotBot"
- "SurveyBot"
- "SynapticSearch"
- "T-H-U-N-D-E-R-S-T-O-N-E"
- "Talkro Web-Shot"
- "Tarantula"
- "TerrawizBot"
- "TheInformant"
- "TMCrawler"
- "TridentSpider"
- "Tutorial Crawler"
- "Twiceler"
- "unwrapbot"
- "URI::Fetch"
- "VengaBot"
- "Vonna.com b o t"
- "Vortex"
- "Votay bot"
- "WebAlta Crawler"
- "Webbot"
- "Webclipping.com"
- "WebCorp"
- "Webinator"
- "WIRE"
- "WISEbot"
- "Xerka WebBot"
- "XSpider"
- "YodaoBot"
- "Yoono"
- "yoono"
+ T{ rules
+ { user-agents V{ "UbiCrawler" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "DOC" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "Zao" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "sitecheck.internetseer.com" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "Zealbot" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "MSIECrawler" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "SiteSnagger" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "WebStripper" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "WebCopier" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "Fetch" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "Offline Explorer" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "Teleport" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "TeleportPro" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "WebZIP" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "linko" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "HTTrack" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "Microsoft.URL.Control" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "Xenu" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "larbin" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "libwww" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "ZyBORG" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "Download Ninja" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "wget" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "grub-client" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "k2spider" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "NPBot" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "WebReaper" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents
+ V{
+ "abot"
+ "ALeadSoftbot"
+ "BeijingCrawler"
+ "BilgiBot"
+ "bot"
+ "botlist"
+ "BOTW Spider"
+ "bumblebee"
+ "Bumblebee"
+ "BuzzRankingBot"
+ "Charlotte"
+ "Clushbot"
+ "Crawler"
+ "CydralSpider"
+ "DataFountains"
+ "DiamondBot"
+ "Dulance bot"
+ "DYNAMIC"
+ "EARTHCOM.info"
+ "EDI"
+ "envolk"
+ "Exabot"
+ "Exabot-Images"
+ "Exabot-Test"
+ "exactseek-pagereaper"
+ "Exalead NG"
+ "FANGCrawl"
+ "Feed::Find"
+ "flatlandbot"
+ "Gigabot"
+ "GigabotSiteSearch"
+ "GurujiBot"
+ "Hatena Antenna"
+ "Hatena Bookmark"
+ "Hatena RSS"
+ "HatenaScreenshot"
+ "Helix"
+ "HiddenMarket"
+ "HyperEstraier"
+ "iaskspider"
+ "IIITBOT"
+ "InfociousBot"
+ "iVia"
+ "iVia Page Fetcher"
+ "Jetbot"
+ "Kolinka Forum Search"
+ "KRetrieve"
+ "LetsCrawl.com"
+ "Lincoln State Web Browser"
+ "Links4US-Crawler"
+ "LOOQ"
+ "Lsearch/sondeur"
+ "MapoftheInternet.com"
+ "NationalDirectory"
+ "NetCarta_WebMapper"
+ "NewsGator"
+ "NextGenSearchBot"
+ "ng"
+ "nicebot"
+ "NP"
+ "NPBot"
+ "Nudelsalat"
+ "Nutch"
+ "OmniExplorer_Bot"
+ "OpenIntelligenceData"
+ "Oracle Enterprise Search"
+ "Pajaczek"
+ "panscient.com"
+ "PeerFactor 404 crawler"
+ "PeerFactor Crawler"
+ "PlantyNet"
+ "PlantyNet_WebRobot"
+ "plinki"
+ "PMAFind"
+ "Pogodak!"
+ "QuickFinder Crawler"
+ "Radiation Retriever"
+ "Reaper"
+ "RedCarpet"
+ "ScorpionBot"
+ "Scrubby"
+ "Scumbot"
+ "searchbot"
+ "Seeker.lookseek.com"
+ "SeznamBot"
+ "ShowXML"
+ "snap.com"
+ "snap.com beta crawler"
+ "Snapbot"
+ "SnapPreviewBot"
+ "sohu"
+ "SpankBot"
+ "Speedy Spider"
+ "Speedy_Spider"
+ "SpeedySpider"
+ "spider"
+ "SquigglebotBot"
+ "SurveyBot"
+ "SynapticSearch"
+ "T-H-U-N-D-E-R-S-T-O-N-E"
+ "Talkro Web-Shot"
+ "Tarantula"
+ "TerrawizBot"
+ "TheInformant"
+ "TMCrawler"
+ "TridentSpider"
+ "Tutorial Crawler"
+ "Twiceler"
+ "unwrapbot"
+ "URI::Fetch"
+ "VengaBot"
+ "Vonna.com b o t"
+ "Vortex"
+ "Votay bot"
+ "WebAlta Crawler"
+ "Webbot"
+ "Webclipping.com"
+ "WebCorp"
+ "Webinator"
+ "WIRE"
+ "WISEbot"
+ "Xerka WebBot"
+ "XSpider"
+ "YodaoBot"
+ "Yoono"
+ "yoono"
+ }
}
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
}
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
}
-}
] [ "vocab:robots/robots.txt" utf8 file-contents parse-robots.txt ] unit-test
USING: accessors http.client kernel unicode.categories
sequences urls splitting combinators splitting.monotonic
combinators.short-circuit assocs unicode.case arrays
-math.parser calendar.format make ;
+math.parser calendar.format make fry present globs
+multiline regexp.combinators regexp ;
IN: robots
! visit-time is GMT, request-rate is pages/second
! crawl-rate is seconds
+
+TUPLE: robots site sitemap rules rules-quot ;
+
+: <robots> ( site sitemap rules -- robots )
+ \ robots new
+ swap >>rules
+ swap >>sitemap
+ swap >>site ;
+
TUPLE: rules user-agents allows disallows
visit-time request-rate crawl-delay unknowns ;
H{ } clone >>unknowns ;
: add-user-agent ( rules agent -- rules ) over user-agents>> push ;
-: add-allow ( rules allow -- rules ) over allows>> push ;
-: add-disallow ( rules disallow -- rules ) over disallows>> push ;
+: add-allow ( rules allow -- rules ) >url over allows>> push ;
+: add-disallow ( rules disallow -- rules ) >url over disallows>> push ;
: parse-robots.txt-line ( rules seq -- rules )
first2 swap {
[ pick unknowns>> push-at ]
} case ;
+: derive-urls ( url seq -- seq' )
+ [ derive-url present ] with { } map-as ;
+
+: robot-rules-quot ( robots -- quot )
+ [
+ [ site>> ] [ rules>> allows>> ] bi
+ derive-urls [ <glob> ] map
+ <or>
+ ] [
+ [ site>> ] [ rules>> disallows>> ] bi
+ derive-urls [ <glob> ] map <and> <not>
+ ] bi 2array <or> '[ _ matches? ] ;
+
PRIVATE>
: parse-robots.txt ( string -- sitemaps rules-seq )
[ <rules> dup ] dip [ parse-robots.txt-line drop ] with each
] map ;
-: robots ( url -- sitemaps rules-seq )
- get-robots.txt nip parse-robots.txt ;
+: robots ( url -- robots )
+ >url
+ dup get-robots.txt nip parse-robots.txt <robots> ;
--- /dev/null
+USING: tools.test sequence-parser unicode.categories kernel
+accessors ;
+IN: sequence-parser.tests
+
+[ "hello" ]
+[ "hello" [ take-rest ] parse-sequence ] unit-test
+
+[ "hi" " how are you?" ]
+[
+ "hi how are you?"
+ [ [ [ current blank? ] take-until ] [ take-rest ] bi ] parse-sequence
+] unit-test
+
+[ "foo" ";bar" ]
+[
+ "foo;bar" [
+ [ CHAR: ; take-until-object ] [ take-rest ] bi
+ ] parse-sequence
+] unit-test
+
+[ "foo " "and bar" ]
+[
+ "foo and bar" [
+ [ "and" take-until-sequence ] [ take-rest ] bi
+ ] parse-sequence
+] unit-test
+
+[ "foo " " bar" ]
+[
+ "foo and bar" [
+ [ "and" take-until-sequence ]
+ [ "and" take-sequence drop ]
+ [ take-rest ] tri
+ ] parse-sequence
+] unit-test
+
+[ "foo " " bar" ]
+[
+ "foo and bar" [
+ [ "and" take-until-sequence* ]
+ [ take-rest ] bi
+ ] parse-sequence
+] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 4 } <sequence-parser> { 3 4 } take-until-sequence ] unit-test
+
+[ f "aaaa" ]
+[
+ "aaaa" <sequence-parser>
+ [ "b" take-until-sequence ] [ take-rest ] bi
+] unit-test
+
+[ 6 ]
+[
+ " foo " [ skip-whitespace n>> ] parse-sequence
+] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 } <sequence-parser> [ current 3 = ] take-until ] unit-test
+
+[ "ab" ]
+[ "abcd" <sequence-parser> "ab" take-sequence ] unit-test
+
+[ f ]
+[ "abcd" <sequence-parser> "lol" take-sequence ] unit-test
+
+[ "ab" ]
+[
+ "abcd" <sequence-parser>
+ [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
+] unit-test
+
+[ "" ]
+[ "abcd" <sequence-parser> "" take-sequence ] unit-test
+
+[ "cd" ]
+[ "abcd" <sequence-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
+
+[ f ]
+[
+ "\"abc\" asdf" <sequence-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
+] unit-test
+
+[ "abc\\\"def" ]
+[
+ "\"abc\\\"def\" asdf" <sequence-parser>
+ CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
+[ "asdf" ]
+[
+ "\"abc\" asdf" <sequence-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ]
+ [ skip-whitespace "asdf" take-sequence ] bi
+] unit-test
+
+[ f ]
+[
+ "\"abc asdf" <sequence-parser>
+ CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
+[ "\"abc" ]
+[
+ "\"abc asdf" <sequence-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ]
+ [ "\"abc" take-sequence ] bi
+] unit-test
+
+[ "c" ]
+[ "c" <sequence-parser> take-token ] unit-test
+
+[ f ]
+[ "" <sequence-parser> take-token ] unit-test
+
+[ "abcd e \\\"f g" ]
+[ "\"abcd e \\\"f g\"" <sequence-parser> CHAR: \ CHAR: " take-token* ] unit-test
+
+[ "" ]
+[ "" <sequence-parser> take-rest ] unit-test
+
+[ "" ]
+[ "abc" <sequence-parser> dup "abc" take-sequence drop take-rest ] unit-test
+
+[ f ]
+[ "abc" <sequence-parser> "abcdefg" take-sequence ] unit-test
+
+[ "1234" ]
+[ "1234f" <sequence-parser> take-integer ] unit-test
+
+[ "yes" ]
+[
+ "yes1234f" <sequence-parser>
+ [ take-integer drop ] [ "yes" take-sequence ] bi
+] unit-test
+
+[ f ] [ "" <sequence-parser> 4 take-n ] unit-test
+[ "abcd" ] [ "abcd" <sequence-parser> 4 take-n ] unit-test
+[ "abcd" "efg" ] [ "abcdefg" <sequence-parser> [ 4 take-n ] [ take-rest ] bi ] unit-test
+
+[ "asdfasdf" ] [
+ "/*asdfasdf*/" <sequence-parser> take-c-comment
+] unit-test
+
+[ "k" ] [
+ "/*asdfasdf*/k" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "omg" ] [
+ "//asdfasdf\nomg" <sequence-parser>
+ [ take-c++-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "omg" ] [
+ "omg" <sequence-parser>
+ [ take-c++-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "/*asdfasdf" ] [
+ "/*asdfasdf" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "asdf" "eoieoei" ] [
+ "//asdf\neoieoei" <sequence-parser>
+ [ take-c++-comment ] [ take-rest ] bi
+] unit-test
+
+[ f "33asdf" ]
+[ "33asdf" <sequence-parser> [ take-c-identifier ] [ take-rest ] bi ] unit-test
+
+[ "asdf" ]
+[ "asdf" <sequence-parser> take-c-identifier ] unit-test
+
+[ "_asdf" ]
+[ "_asdf" <sequence-parser> take-c-identifier ] unit-test
+
+[ "_asdf400" ]
+[ "_asdf400" <sequence-parser> take-c-identifier ] unit-test
+
+[ "123" ]
+[ "123jjj" <sequence-parser> take-c-integer ] unit-test
+
+[ "123uLL" ]
+[ "123uLL" <sequence-parser> take-c-integer ] unit-test
+
+[ "123ull" ]
+[ "123ull" <sequence-parser> take-c-integer ] unit-test
+
+[ "123u" ]
+[ "123u" <sequence-parser> take-c-integer ] unit-test
+
+[ 36 ]
+[
+ " //jofiejoe\n //eoieow\n/*asdf*/\n "
+ <sequence-parser> skip-whitespace/comments n>>
+] unit-test
+
+[ f ]
+[ "\n" <sequence-parser> take-integer ] unit-test
+
+[ "\n" ] [ "\n" <sequence-parser> [ ] take-while ] unit-test
+[ f ] [ "\n" <sequence-parser> [ not ] take-while ] unit-test
--- /dev/null
+! Copyright (C) 2005, 2009 Daniel Ehrenberg, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces math kernel sequences accessors fry circular
+unicode.case unicode.categories locals combinators.short-circuit
+make combinators io splitting math.parser math.ranges
+generalizations sorting.functor math.order sorting.slots ;
+IN: sequence-parser
+
+TUPLE: sequence-parser sequence n ;
+
+: <sequence-parser> ( sequence -- sequence-parser )
+ sequence-parser new
+ swap >>sequence
+ 0 >>n ;
+
+:: with-sequence-parser ( sequence-parser quot -- seq/f )
+ sequence-parser n>> :> n
+ sequence-parser quot call [
+ n sequence-parser (>>n) f
+ ] unless* ; inline
+
+: offset ( sequence-parser offset -- char/f )
+ swap
+ [ n>> + ] [ sequence>> ?nth ] bi ; inline
+
+: current ( sequence-parser -- char/f ) 0 offset ; inline
+
+: previous ( sequence-parser -- char/f ) -1 offset ; inline
+
+: peek-next ( sequence-parser -- char/f ) 1 offset ; inline
+
+: advance ( sequence-parser -- sequence-parser )
+ [ 1 + ] change-n ; inline
+
+: advance* ( sequence-parser -- )
+ advance drop ; inline
+
+: get+increment ( sequence-parser -- char/f )
+ [ current ] [ advance drop ] bi ; inline
+
+:: skip-until ( sequence-parser quot: ( obj -- ? ) -- )
+ sequence-parser current [
+ sequence-parser quot call
+ [ sequence-parser advance quot skip-until ] unless
+ ] when ; inline recursive
+
+: sequence-parse-end? ( sequence-parser -- ? ) current not ;
+
+: take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
+ over sequence-parse-end? [
+ 2drop f
+ ] [
+ [ drop n>> ]
+ [ skip-until ]
+ [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like
+ ] if ; inline
+
+: take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
+ [ not ] compose take-until ; inline
+
+: <safe-slice> ( from to seq -- slice/f )
+ 3dup {
+ [ 2drop 0 < ]
+ [ [ drop ] 2dip length > ]
+ [ drop > ]
+ } 3|| [ 3drop f ] [ slice boa ] if ; inline
+
+:: take-sequence ( sequence-parser sequence -- obj/f )
+ sequence-parser [ n>> dup sequence length + ] [ sequence>> ] bi
+ <safe-slice> sequence sequence= [
+ sequence
+ sequence-parser [ sequence length + ] change-n drop
+ ] [
+ f
+ ] if ;
+
+: take-sequence* ( sequence-parser sequence -- )
+ take-sequence drop ;
+
+:: take-until-sequence ( sequence-parser sequence -- sequence'/f )
+ sequence-parser n>> :> saved
+ sequence length <growing-circular> :> growing
+ sequence-parser
+ [
+ current growing push-growing-circular
+ sequence growing sequence=
+ ] take-until :> found
+ growing sequence sequence= [
+ found dup length
+ growing length 1- - head
+ sequence-parser [ growing length - 1 + ] change-n drop
+ ! sequence-parser advance drop
+ ] [
+ saved sequence-parser (>>n)
+ f
+ ] if ;
+
+:: take-until-sequence* ( sequence-parser sequence -- sequence'/f )
+ sequence-parser sequence take-until-sequence :> out
+ out [
+ sequence-parser [ sequence length + ] change-n drop
+ ] when out ;
+
+: skip-whitespace ( sequence-parser -- sequence-parser )
+ [ [ current blank? not ] take-until drop ] keep ;
+
+: skip-whitespace-eol ( sequence-parser -- sequence-parser )
+ [ [ current " \t\r" member? not ] take-until drop ] keep ;
+
+: take-c-comment ( sequence-parser -- seq/f )
+ [
+ dup "/*" take-sequence [
+ "*/" take-until-sequence*
+ ] [
+ drop f
+ ] if
+ ] with-sequence-parser ;
+
+: take-c++-comment ( sequence-parser -- seq/f )
+ [
+ dup "//" take-sequence [
+ [
+ [
+ { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1||
+ ] take-until
+ ] [
+ advance drop
+ ] bi
+ ] [
+ drop f
+ ] if
+ ] with-sequence-parser ;
+
+: skip-whitespace/comments ( sequence-parser -- sequence-parser )
+ skip-whitespace-eol
+ {
+ { [ dup take-c-comment ] [ skip-whitespace/comments ] }
+ { [ dup take-c++-comment ] [ skip-whitespace/comments ] }
+ [ ]
+ } cond ;
+
+: take-define-identifier ( sequence-parser -- string )
+ skip-whitespace/comments
+ [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
+
+: take-rest-slice ( sequence-parser -- sequence/f )
+ [ sequence>> ] [ n>> ] bi
+ 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
+
+: take-rest ( sequence-parser -- sequence )
+ [ take-rest-slice ] [ sequence>> like ] bi ;
+
+: take-until-object ( sequence-parser obj -- sequence )
+ '[ current _ = ] take-until ;
+
+: parse-sequence ( sequence quot -- )
+ [ <sequence-parser> ] dip call ; inline
+
+:: take-quoted-string ( sequence-parser escape-char quote-char -- string )
+ sequence-parser n>> :> start-n
+ sequence-parser advance
+ [
+ {
+ [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
+ [ current quote-char = not ]
+ } 1||
+ ] take-while :> string
+ sequence-parser current quote-char = [
+ sequence-parser advance* string
+ ] [
+ start-n sequence-parser (>>n) f
+ ] if ;
+
+: (take-token) ( sequence-parser -- string )
+ skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
+
+:: take-token* ( sequence-parser escape-char quote-char -- string/f )
+ sequence-parser skip-whitespace
+ dup current {
+ { quote-char [ escape-char quote-char take-quoted-string ] }
+ { f [ drop f ] }
+ [ drop (take-token) ]
+ } case ;
+
+: take-token ( sequence-parser -- string/f )
+ CHAR: \ CHAR: " take-token* ;
+
+: take-integer ( sequence-parser -- n/f )
+ [ current digit? ] take-while ;
+
+:: take-n ( sequence-parser n -- seq/f )
+ n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
+ f
+ ] [
+ sequence-parser n>> dup n + sequence-parser sequence>> subseq
+ sequence-parser [ n + ] change-n drop
+ ] if ;
+
+: c-identifier-begin? ( ch -- ? )
+ CHAR: a CHAR: z [a,b]
+ CHAR: A CHAR: Z [a,b]
+ { CHAR: _ } 3append member? ;
+
+: c-identifier-ch? ( ch -- ? )
+ CHAR: a CHAR: z [a,b]
+ CHAR: A CHAR: Z [a,b]
+ CHAR: 0 CHAR: 9 [a,b]
+ { CHAR: _ } 4 nappend member? ;
+
+: (take-c-identifier) ( sequence-parser -- string/f )
+ dup current c-identifier-begin? [
+ [ current c-identifier-ch? ] take-while
+ ] [
+ drop f
+ ] if ;
+
+: take-c-identifier ( sequence-parser -- string/f )
+ [ (take-c-identifier) ] with-sequence-parser ;
+
+<< "length" [ length ] define-sorting >>
+
+: sort-tokens ( seq -- seq' )
+ { length>=< <=> } sort-by ;
+
+: take-first-matching ( sequence-parser seq -- seq )
+ swap
+ '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
+
+
+: take-longest ( sequence-parser seq -- seq )
+ sort-tokens take-first-matching ;
+
+: take-c-integer ( sequence-parser -- string/f )
+ [
+ dup take-integer [
+ swap
+ { "ull" "uLL" "Ull" "ULL" "ll" "LL" "l" "L" "u" "U" }
+ take-longest [ append ] when*
+ ] [
+ drop f
+ ] if*
+ ] with-sequence-parser ;
+
+CONSTANT: c-punctuators
+ {
+ "[" "]" "(" ")" "{" "}" "." "->"
+ "++" "--" "&" "*" "+" "-" "~" "!"
+ "/" "%" "<<" ">>" "<" ">" "<=" ">=" "==" "!=" "^" "|" "&&" "||"
+ "?" ":" ";" "..."
+ "=" "*=" "/=" "%=" "+=" "-=" "<<=" ">>=" "&=" "^=" "|="
+ "," "#" "##"
+ "<:" ":>" "<%" "%>" "%:" "%:%:"
+ }
+
+: take-c-punctuator ( sequence-parser -- string/f )
+ c-punctuators take-longest ;
+
+: write-full ( sequence-parser -- ) sequence>> write ;
+: write-rest ( sequence-parser -- ) take-rest write ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors continuations db db.sqlite db.tuples db.types
io.directories io.files.temp kernel io.streams.string calendar
-debugger combinators.smart sequences ;
+debugger combinators.smart sequences arrays ;
IN: site-watcher.db
-TUPLE: account account-id account-name email twitter sms ;
+TUPLE: account account-name email twitter sms ;
: <account> ( account-name email -- account )
account new
site new
swap >>url ;
+: site-with-url ( url -- site )
+ <site> select-tuple ;
+
+: site-with-id ( id -- site )
+ site new swap >>site-id select-tuple ;
+
site "SITE" {
{ "site-id" "SITE_ID" INTEGER +db-assigned-id+ }
{ "url" "URL" VARCHAR }
{ "site-id" "SITE_ID" INTEGER +user-assigned-id+ }
} define-persistent
-TUPLE: reporting-site email url up? changed? last-up? error last-error ;
+TUPLE: spidering-site < watching-site max-depth max-count ;
+
+C: <spidering-site> spidering-site
+
+SLOT: site
-<PRIVATE
+M: watching-site site>>
+ site-id>> site-with-id ;
+
+SLOT: account
+
+M: watching-site account>>
+ account-name>> account new swap >>account-name select-tuple ;
+
+spidering-site "SPIDERING_SITE" {
+ { "max-depth" "MAX_DEPTH" INTEGER }
+ { "max-count" "MAX_COUNT" INTEGER }
+} define-persistent
+
+: spidering-sites ( username -- sites )
+ spidering-site new swap >>account-name select-tuples ;
+
+: insert-site ( url -- site )
+ <site> dup select-tuple [ ] [ dup t >>up? insert-tuple ] ?if ;
+
+: select-account/site ( username url -- account site )
+ insert-site site-id>> ;
+
+: add-spidered-site ( username url -- )
+ select-account/site 10 10 <spidering-site> insert-tuple ;
+
+: remove-spidered-site ( username url -- )
+ select-account/site 10 10 <spidering-site> delete-tuples ;
+
+TUPLE: reporting-site site-id email url up? changed? last-up? error last-error ;
: set-notify-site-watchers ( site new-up? -- site )
[ over up?>> = [ t >>changed? ] unless ] keep >>up? ;
[ [ reporting-site boa ] input<sequence ] map
"update site set changed = 0;" sql-command ;
-: insert-site ( url -- site )
- <site> dup select-tuple [ ] [ dup t >>up? insert-tuple ] ?if ;
-
: insert-account ( account-name email -- ) <account> insert-tuple ;
: find-sites ( -- seq ) f <site> select-tuples ;
-: select-account/site ( username url -- account site )
- insert-site site-id>> ;
-
-PRIVATE>
-
: watch-site ( username url -- )
select-account/site <watching-site> insert-tuple ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: smtp namespaces accessors kernel arrays ;
+IN: site-watcher.email
+
+SYMBOL: site-watcher-from
+site-watcher-from [ "factor-site-watcher@gmail.com" ] initialize
+
+: send-site-email ( watching-site body subject -- )
+ [ account>> email>> ] 2dip
+ pick [
+ [ <email> site-watcher-from get >>from ] 3dip
+ [ 1array >>to ] [ >>body ] [ >>subject ] tri* send-email
+ ] [ 3drop ] if ;
\ No newline at end of file
! See http://factorcode.org/license.txt for BSD license.
USING: db.tuples locals site-watcher site-watcher.db
site-watcher.private kernel db io.directories io.files.temp
-continuations site-watcher.db.private db.sqlite
+continuations db.sqlite
sequences tools.test ;
IN: site-watcher.tests
USING: accessors alarms arrays calendar combinators
combinators.smart continuations debugger http.client fry
init io.streams.string kernel locals math math.parser db
-namespaces sequences site-watcher.db site-watcher.db.private
-smtp ;
+namespaces sequences site-watcher.db site-watcher.email ;
IN: site-watcher
-SYMBOL: site-watcher-from
-"factor-site-watcher@gmail.com" site-watcher-from set-global
-
SYMBOL: site-watcher-frequency
5 minutes site-watcher-frequency set-global
[ dup url>> http-get 2drop site-good ] [ site-bad ] recover
] each ;
-: site-up-email ( email site -- email )
+: site-up-email ( site -- body )
last-up>> now swap time- duration>minutes 60 /mod
[ >integer number>string ] bi@
[ " hours, " append ] [ " minutes" append ] bi* append
- "Site was down for (at least): " prepend >>body ;
+ "Site was down for (at least): " prepend ;
-: site-down-email ( email site -- email ) error>> >>body ;
+: site-down-email ( site -- body ) error>> ;
: send-report ( site -- )
- [ <email> ] dip
- {
- [ email>> 1array >>to ]
- [ drop site-watcher-from get "factor.site.watcher@gmail.com" or >>from ]
- [ dup up?>> [ site-up-email ] [ site-down-email ] if ]
- [ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue >>subject ]
- } cleave send-email ;
+ [ ]
+ [ dup up?>> [ site-up-email ] [ site-down-email ] if ]
+ [ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue ] tri
+ send-site-email ;
: send-reports ( seq -- )
[ ] [ [ send-report ] each ] if-empty ;
PRIVATE>
-: watch-sites ( db -- )
- [ find-sites check-sites sites-to-report send-reports ] with-db ;
+: watch-sites ( -- )
+ find-sites check-sites sites-to-report send-reports ;
: run-site-watcher ( db -- )
[ running-site-watcher get ] dip '[
- [ _ watch-sites ] site-watcher-frequency get every
+ [ _ [ watch-sites ] with-db ] site-watcher-frequency get every
running-site-watcher set
] unless ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: site-watcher.db site-watcher.email site-watcher.spider
+spider spider.report
+accessors kernel sequences
+xml.writer concurrency.combinators ;
+IN: site-watcher.spider
+
+: <site-spider> ( spidering-site -- spider )
+ [ max-depth>> ]
+ [ max-count>> ]
+ [ site>> url>> ]
+ tri
+ <spider>
+ swap >>max-count
+ swap >>max-depth ;
+
+: spider-and-email ( spidering-site -- )
+ [ ]
+ [ <site-spider> run-spider spider-report xml>string ]
+ [ site>> url>> "Spidered " prefix ] tri
+ send-site-email ;
+
+: spider-sites ( -- )
+ f spidering-sites [ spider-and-email ] parallel-each ;
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators kernel math
+math.statistics namespaces sequences sorting xml.syntax
+spider urls html ;
+IN: spider.report
+
+SYMBOL: network-failures
+SYMBOL: broken-pages
+SYMBOL: timings
+
+: record-broken-page ( url spider-result -- )
+ headers>> [ code>> ] [ message>> ] bi 2array 2array
+ broken-pages push ;
+
+: record-page-timings ( url spider-result -- )
+ fetched-in>> 2array timings get push ;
+
+: record-network-failure ( url -- )
+ network-failures get push ;
+
+: process-result ( url spider-result -- )
+ {
+ { f [ record-network-failure ] }
+ [
+ dup headers>> code>> 200 =
+ [ record-page-timings ] [ record-broken-page ] if
+ ]
+ } case ;
+
+CONSTANT: slowest 5
+
+SYMBOL: slowest-pages
+SYMBOL: mean-time
+SYMBOL: median-time
+SYMBOL: time-std
+
+: process-timings ( -- )
+ timings get sort-values
+ [ slowest short tail* reverse slowest-pages set ]
+ [
+ values [
+ [ mean 1000000 /f mean-time set ]
+ [ median 1000000 /f median-time set ]
+ [ std 1000000 /f time-std set ] tri
+ ] unless-empty
+ ] bi ;
+
+: process-results ( results -- )
+ V{ } clone network-failures set
+ V{ } clone broken-pages set
+ V{ } clone timings set
+ [ process-result ] assoc-each
+ process-timings ;
+
+: info-table ( alist -- html )
+ [
+ first2 dupd 1000000 /f
+ [XML
+ <tr><td><a href=<->><-></a></td><td><-> seconds</td></tr>
+ XML]
+ ] map [XML <table border="1"><-></table> XML] ;
+
+: report-broken-pages ( -- html )
+ broken-pages get info-table ;
+
+: report-network-failures ( -- html )
+ network-failures get [
+ dup [XML <li><a href=<->><-></a></li> XML]
+ ] map [XML <ul><-></ul> XML] ;
+
+: slowest-pages-table ( -- html )
+ slowest-pages get info-table ;
+
+: timing-summary-table ( -- html )
+ mean-time get
+ median-time get
+ time-std get
+ [XML
+ <table border="1">
+ <tr><th>Mean</th><td><-> seconds</td></tr>
+ <tr><th>Median</th><td><-> seconds</td></tr>
+ <tr><th>Standard deviation</th><td><-> seconds</td></tr>
+ </table>
+ XML] ;
+
+: report-timings ( -- html )
+ slowest-pages-table
+ timing-summary-table
+ [XML
+ <h3>Slowest pages</h3>
+ <->
+
+ <h3>Summary</h3>
+ <->
+ XML] ;
+
+: generate-report ( -- html )
+ url get dup
+ report-broken-pages
+ report-network-failures
+ report-timings
+ [XML
+ <h1>Spider report</h1>
+ URL: <a href=<->><-></a>
+
+ <h2>Broken pages</h2>
+ <->
+
+ <h2>Network failures</h2>
+ <->
+
+ <h2>Load times</h2>
+ <->
+ XML] ;
+
+: spider-report ( spider -- html )
+ [ "Spider report" f ] dip
+ [
+ [ base>> url set ]
+ [ spidered>> process-results ] bi
+ generate-report
+ ] with-scope
+ simple-page ;
http.client kernel tools.time sets assocs sequences
concurrency.combinators io threads namespaces math multiline
math.parser inspector urls logging combinators.short-circuit
-continuations calendar prettyprint dlists deques locals ;
+continuations calendar prettyprint dlists deques locals
+spider.unique-deque combinators concurrency.semaphores ;
IN: spider
TUPLE: spider base count max-count sleep max-depth initial-links
-filters spidered todo nonmatching quiet ;
+filters spidered todo nonmatching quiet currently-spidering
+#threads semaphore follow-robots? robots ;
-TUPLE: spider-result url depth headers fetch-time parsed-html
-links processing-time timestamp ;
-
-TUPLE: todo-url url depth ;
-
-: <todo-url> ( url depth -- todo-url )
- todo-url new
- swap >>depth
- swap >>url ;
-
-TUPLE: unique-deque assoc deque ;
-
-: <unique-deque> ( -- unique-deque )
- H{ } clone <dlist> unique-deque boa ;
-
-: push-url ( url depth unique-deque -- )
- [ <todo-url> ] dip
- [ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ]
- [ deque>> push-back ] 2bi ;
-
-: pop-url ( unique-deque -- todo-url ) deque>> pop-front ;
-
-: peek-url ( unique-deque -- todo-url ) deque>> peek-front ;
+TUPLE: spider-result url depth headers
+fetched-in parsed-html links processed-in fetched-at ;
: <spider> ( base -- spider )
>url
spider new
over >>base
+ over >>currently-spidering
swap 0 <unique-deque> [ push-url ] keep >>todo
<unique-deque> >>nonmatching
0 >>max-depth
0 >>count
1/0. >>max-count
- H{ } clone >>spidered ;
+ H{ } clone >>spidered
+ 1 [ >>#threads ] [ <semaphore> >>semaphore ] bi ;
+
+: <spider-result> ( url depth -- spider-result )
+ spider-result new
+ swap >>depth
+ swap >>url ;
<PRIVATE
[ add-nonmatching ]
[ tuck [ apply-filters ] 2dip add-todo ] 2bi ;
-: normalize-hrefs ( links spider -- links' )
- [ [ >url ] map ] dip
- base>> swap [ derive-url ] with map ;
+: normalize-hrefs ( base links -- links' )
+ [ derive-url ] with map ;
-: print-spidering ( url depth -- )
+: print-spidering ( spider-result -- )
+ [ url>> ] [ depth>> ] bi
"depth: " write number>string write
", spidering: " write . yield ;
-:: new-spidered-result ( spider url depth -- spider-result )
- f url spider spidered>> set-at
- [ url http-get ] benchmark :> fetch-time :> html :> headers
+:: fill-spidered-result ( spider spider-result -- )
+ f spider-result url>> spider spidered>> set-at
+ [ spider-result url>> http-get ] benchmark :> fetched-in :> html :> headers
[
- html parse-html [ ] [ find-hrefs spider normalize-hrefs ] bi
- ] benchmark :> processing-time :> links :> parsed-html
- url depth headers fetch-time parsed-html links processing-time
- now spider-result boa ;
-
-:: spider-page ( spider url depth -- )
- spider quiet>> [ url depth print-spidering ] unless
- spider url depth new-spidered-result :> spidered-result
- spider quiet>> [ spidered-result describe ] unless
- spider spidered-result add-spidered ;
+ html parse-html
+ spider currently-spidering>>
+ over find-all-links normalize-hrefs
+ ] benchmark :> processed-in :> links :> parsed-html
+ spider-result
+ headers >>headers
+ fetched-in >>fetched-in
+ parsed-html >>parsed-html
+ links >>links
+ processed-in >>processed-in
+ now >>fetched-at drop ;
+
+:: spider-page ( spider spider-result -- )
+ spider quiet>> [ spider-result print-spidering ] unless
+ spider spider-result fill-spidered-result
+ spider quiet>> [ spider-result describe ] unless
+ spider spider-result add-spidered ;
\ spider-page ERROR add-error-logging
-: spider-sleep ( spider -- )
- sleep>> [ sleep ] when* ;
+: spider-sleep ( spider -- ) sleep>> [ sleep ] when* ;
-:: queue-initial-links ( spider -- spider )
- spider initial-links>> spider normalize-hrefs 0 spider add-todo spider ;
+: queue-initial-links ( spider -- )
+ [
+ [ currently-spidering>> ] [ initial-links>> ] bi normalize-hrefs 0
+ ] keep add-todo ;
: spider-page? ( spider -- ? )
{
[ [ count>> ] [ max-count>> ] bi < ]
} 1&& ;
-: setup-next-url ( spider -- spider url depth )
- dup todo>> pop-url [ url>> ] [ depth>> ] bi ;
+: setup-next-url ( spider -- spider spider-result )
+ dup todo>> peek-url url>> >>currently-spidering
+ dup todo>> pop-url [ url>> ] [ depth>> ] bi <spider-result> ;
: spider-next-page ( spider -- )
setup-next-url spider-page ;
: run-spider-loop ( spider -- )
dup spider-page? [
- [ spider-next-page ] [ run-spider-loop ] bi
+ [ spider-next-page ] [ spider-sleep ] [ run-spider-loop ] tri
] [
drop
] if ;
: run-spider ( spider -- spider )
"spider" [
- queue-initial-links [ run-spider-loop ] keep
+ dup queue-initial-links [ run-spider-loop ] keep
] with-logging ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs deques dlists kernel spider ;
+IN: spider.unique-deque
+
+TUPLE: todo-url url depth ;
+
+: <todo-url> ( url depth -- todo-url )
+ todo-url new
+ swap >>depth
+ swap >>url ;
+
+TUPLE: unique-deque assoc deque ;
+
+: <unique-deque> ( -- unique-deque )
+ H{ } clone <dlist> unique-deque boa ;
+
+: url-exists? ( url unique-deque -- ? )
+ [ url>> ] [ assoc>> ] bi* key? ;
+
+: push-url ( url depth unique-deque -- )
+ [ <todo-url> ] dip 2dup url-exists? [
+ 2drop
+ ] [
+ [ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ]
+ [ deque>> push-back ] 2bi
+ ] if ;
+
+: pop-url ( unique-deque -- todo-url ) deque>> pop-front ;
+
+: peek-url ( unique-deque -- todo-url ) deque>> peek-front ;
+
+: slurp-deque-when ( deque quot1 quot2: ( value -- ) -- )
+ pick deque-empty? [ 3drop ] [
+ [ [ pop-front dup ] 2dip slip [ t ] compose [ drop f ] if ]
+ [ roll [ slurp-deque-when ] [ 3drop ] if ] 3bi
+ ] if ; inline recursive
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: combinators io io.files io.files.links io.directories
io.pathnames io.streams.string kernel math math.parser
continuations namespaces pack prettyprint sequences strings
system tools.hexdump io.encodings.binary summary accessors
-io.backend byte-arrays ;
+io.backend byte-arrays io.streams.byte-array splitting ;
IN: tar
CONSTANT: zero-checksum 256
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
linkname magic version uname gname devmajor devminor prefix ;
-ERROR: checksum-error ;
-SYMBOLS: base-dir filename ;
+ERROR: checksum-error ;
-: tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
+: trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
-: read-c-string* ( n -- str/f )
+: read-c-string ( n -- str/f )
read [ zero? ] trim-tail [ f ] when-empty ;
: read-tar-header ( -- obj )
\ tar-header new
- 100 read-c-string* >>name
- 8 read-c-string* tar-trim oct> >>mode
- 8 read-c-string* tar-trim oct> >>uid
- 8 read-c-string* tar-trim oct> >>gid
- 12 read-c-string* tar-trim oct> >>size
- 12 read-c-string* tar-trim oct> >>mtime
- 8 read-c-string* tar-trim oct> >>checksum
- read1 >>typeflag
- 100 read-c-string* >>linkname
- 6 read >>magic
- 2 read >>version
- 32 read-c-string* >>uname
- 32 read-c-string* >>gname
- 8 read tar-trim oct> >>devmajor
- 8 read tar-trim oct> >>devminor
- 155 read-c-string* >>prefix ;
-
-: header-checksum ( seq -- x )
- 148 cut-slice 8 tail-slice
- [ sum ] bi@ + 256 + ;
+ 100 read-c-string >>name
+ 8 read-c-string trim-string oct> >>mode
+ 8 read-c-string trim-string oct> >>uid
+ 8 read-c-string trim-string oct> >>gid
+ 12 read-c-string trim-string oct> >>size
+ 12 read-c-string trim-string oct> >>mtime
+ 8 read-c-string trim-string oct> >>checksum
+ read1 >>typeflag
+ 100 read-c-string >>linkname
+ 6 read >>magic
+ 2 read >>version
+ 32 read-c-string >>uname
+ 32 read-c-string >>gname
+ 8 read trim-string oct> >>devmajor
+ 8 read trim-string oct> >>devminor
+ 155 read-c-string >>prefix ;
+
+: checksum-header ( seq -- n )
+ 148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ;
: read-data-blocks ( tar-header -- )
dup size>> 0 > [
] if ;
: parse-tar-header ( seq -- obj )
- [ header-checksum ] keep over zero-checksum = [
+ [ checksum-header ] keep over zero-checksum = [
2drop
\ tar-header new
0 >>size
0 >>checksum
] [
- [ read-tar-header ] with-string-reader
+ binary [ read-tar-header ] with-byte-reader
[ checksum>> = [ checksum-error ] unless ] keep
] if ;
ERROR: unknown-typeflag ch ;
-M: unknown-typeflag summary ( obj -- str )
- ch>> 1string "Unknown typeflag: " prepend ;
-: tar-prepend-path ( path -- newpath )
- base-dir get prepend-path ;
+M: unknown-typeflag summary ( obj -- str )
+ ch>> [ "Unknown typeflag: " ] dip prefix ;
: read/write-blocks ( tar-header path -- )
binary [ read-data-blocks ] with-file-writer ;
+: prepend-current-directory ( path -- path' )
+ current-directory get prepend-path ;
+
! Normal file
: typeflag-0 ( header -- )
- dup name>> tar-prepend-path read/write-blocks ;
+ dup name>> dup "global_pax_header" = [
+ drop [ read-data-blocks ] with-string-writer drop
+ ] [
+ prepend-current-directory read/write-blocks
+ ] if ;
! Hard link
: typeflag-1 ( header -- ) unknown-typeflag ;
! Directory
: typeflag-5 ( header -- )
- name>> tar-prepend-path make-directories ;
+ name>> prepend-current-directory make-directories ;
! FIFO
: typeflag-6 ( header -- ) unknown-typeflag ;
drop ;
! <string-writer> [ read-data-blocks ] keep
! >string [ zero? ] trim-tail filename set
- ! filename get tar-prepend-path make-directories ;
+ ! filename get prepend-current-directory make-directories ;
! Multi volume continuation entry
: typeflag-M ( header -- ) unknown-typeflag ;
: typeflag-X ( header -- ) unknown-typeflag ;
: (parse-tar) ( -- )
- block-size read dup length 512 = [
+ block-size read dup length block-size = [
parse-tar-header
dup typeflag>>
{
drop
] if ;
-: parse-tar ( path -- )
- normalize-path dup parent-directory base-dir [
+: untar ( path -- )
+ normalize-path [ ] [ parent-directory ] bi [
binary [ (parse-tar) ] with-file-reader
- ] with-variable ;
+ ] with-directory ;
: draw-tetris ( width height tetris -- )
#! width and height are in pixels
- GL_MODELVIEW [
+ [
{
[ board>> scale-board ]
[ board>> draw-board ]
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel quotations ui.gadgets
-images.bitmap strings ui.gadgets.worlds ;
+images strings ui.gadgets.worlds ;
IN: ui.offscreen
HELP: <offscreen-world>
HELP: gadget>bitmap
{ $values
{ "gadget" gadget }
- { "bitmap" bitmap }
+ { "image" image }
}
-{ $description "Renders " { $snippet "gadget" } " to an " { $link offscreen-world } " and creates a " { $link bitmap } " from its contents." } ;
+{ $description "Renders " { $snippet "gadget" } " to an " { $link offscreen-world } " and creates an " { $link image } " from its contents." } ;
HELP: offscreen-world
{ $class-description "The class of " { $link world } " objects that render to an offscreen buffer." } ;
HELP: offscreen-world>bitmap
{ $values
{ "world" offscreen-world }
- { "bitmap" bitmap }
+ { "image" image }
}
-{ $description "Saves a copy of the contents of " { $snippet "world" } " to a " { $link bitmap } " object." } ;
+{ $description "Saves a copy of the contents of " { $snippet "world" } " to a " { $link image } " object." } ;
HELP: open-offscreen
{ $values
! (c) 2008 Joe Groff, see license for details
-USING: accessors continuations images.bitmap kernel math
-sequences ui.gadgets ui.gadgets.worlds ui ui.backend
-destructors ;
+USING: accessors alien.c-types continuations images kernel math
+sequences ui.gadgets ui.gadgets.private ui.gadgets.worlds
+ui.private ui ui.backend destructors locals ;
IN: ui.offscreen
TUPLE: offscreen-world < world ;
: open-offscreen ( gadget -- world )
"" f <offscreen-world>
- [ open-world-window dup relayout-1 ] keep
+ [ open-world-window ] [ relayout-1 ] [ ] tri
notify-queued ;
: close-offscreen ( world -- )
ungraft notify-queued ;
-: offscreen-world>bitmap ( world -- bitmap )
- offscreen-pixels bgra>bitmap ;
+:: bgrx>bitmap ( alien w h -- image )
+ <image>
+ { w h } >>dim
+ alien w h * 4 * memory>byte-array >>bitmap
+ BGRX >>component-order ;
+
+: offscreen-world>bitmap ( world -- image )
+ offscreen-pixels bgrx>bitmap ;
: do-offscreen ( gadget quot: ( offscreen-world -- ) -- )
[ open-offscreen ] dip
over [ slip ] [ close-offscreen ] [ ] cleanup ; inline
-: gadget>bitmap ( gadget -- bitmap )
+: gadget>bitmap ( gadget -- image )
[ offscreen-world>bitmap ] do-offscreen ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: http.server.dispatchers ;
+IN: webapps.site-watcher.common
+
+TUPLE: site-watcher-app < dispatcher ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<p>SiteWatcher is a free service for web masters. It periodically tries fetching your web site via HTTP, and sends you an e-mail, SMS or Tweet if this fails. <t:a t:href="$site-watcher-app/login">Sign up now!</t:a></p>
+
+<ul>
+ <li><t:a t:href="$site-watcher-app/update-notify">Your contact info</t:a></li>
+ <li><t:a t:href="$site-watcher-app/watch-list">Watched sites</t:a></li>
+ <li><t:a t:href="$site-watcher-app/spider-list">Spidered sites</t:a></li>
+</ul>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<h1>Add some sites to watch</h1>
+
+<t:form t:action="$site-watcher-app/add-watch">
+<table>
+ <tr><th>URL:</th><td> <t:field t:name="url" t:size="80" /> <button type="submit">Done</button> </td></tr>
+</table>
+</t:form>
+
+<h1>Keep track of your sites</h1>
+
+<table border="2">
+ <tr> <th>URL</th><th></th> </tr>
+ <t:bind-each t:name="sites">
+ <tr>
+ <td> <t:label t:name="url" /> </td>
+ <td> <t:button t:action="$site-watcher-app/remove-watch" t:for="url">Remove</t:button> </td>
+ </tr>
+ </t:bind-each>
+</table>
+<p>
+ <t:button t:action="$site-watcher-app/check">Check now</t:button>
+</p>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<html>
+ <head>
+ <title>SiteWatcher</title>
+ </head>
+ <body>
+ <h1>SiteWatcher</h1>
+ <h2>It tells you if your web site goes down.</h2>
+ <t:call-next-template />
+ </body>
+</html>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<h1>Add a site to spider</h1>
+
+<t:form t:action="$site-watcher-app/add-spider">
+<table>
+ <tr><th>URL:</th><td> <t:field t:name="url" t:size="80" /> <button type="submit">Done</button> </td></tr>
+</table>
+</t:form>
+
+<h1>Spidered sites</h1>
+
+<table border="2">
+ <tr> <th>URL</th><th></th> </tr>
+ <t:bind-each t:name="sites">
+ <tr>
+ <td> <t:label t:name="url" /> </td>
+ <td> <t:button t:action="$site-watcher-app/remove-spider" t:for="url">Remove</t:button> </td>
+ </tr>
+ </t:bind-each>
+</table>
+<p>
+ <t:button t:action="$site-watcher-app/spider">Spider now</t:button>
+</p>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<h3>Enter your contact details</h3>
+
+<t:form t:action="$site-watcher-app/update-notify">
+<table>
+ <tr><th>E-mail:</th><td><t:field t:name="email" t:size="80" /></td></tr>
+ <tr><th>Twitter:</th><td><t:field t:name="twitter" t:size="80" /></td></tr>
+ <tr><th>SMS:</th><td><t:field t:name="sms" t:size="80" /></td></tr>
+</table>
+<p> <button type="submit">Done</button> </p>
+</t:form>
+
+</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
-<p>SiteWatcher is a free service for web masters. It periodically tries fetching your web site via HTTP, and sends you an e-mail, SMS or Tweet if this fails. <t:a t:href="$site-watcher-app/list">Sign up now!</t:a></p>
-
-</t:chloe>
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
-<p> Don't you hate it when your web site goes down, and all your users go buy that <a href="http://en.wikipedia.org/wiki/Slanket">slanket</a> from your competitor instead. Now using SiteWatcher, you can ensure this will never happen again! </p>
-
-<t:a t:href="$site-watcher-app/update-notify">Contact info</t:a>
-
-<h3>Step 2: add some sites to watch</h3>
-
-<t:form t:action="$site-watcher-app/add">
-<table>
- <tr><th>URL:</th><td> <t:field t:name="url" t:size="80" /> <button type="submit">Done</button> </td></tr>
-</table>
-</t:form>
-
-<h3>Step 3: keep track of your sites</h3>
-
-<table border="2">
- <tr> <th>URL</th><th></th> </tr>
- <t:bind-each t:name="sites">
- <tr>
- <td> <t:label t:name="url" /> </td>
- <td> <t:button t:action="$site-watcher-app/remove" t:for="url">Remove</t:button> </td>
- </tr>
- </t:bind-each>
-</table>
-<p>
- <t:button t:action="$site-watcher-app/check">Check now</t:button>
-</p>
-
-</t:chloe>
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs db.sqlite furnace furnace.actions furnace.alloy
-furnace.auth furnace.auth.features.deactivate-user
+USING: accessors assocs db.sqlite furnace furnace.actions
+furnace.alloy furnace.auth furnace.auth.features.deactivate-user
furnace.auth.features.edit-profile
furnace.auth.features.recover-password
furnace.auth.features.registration furnace.auth.login
furnace.boilerplate furnace.redirection html.forms http.server
http.server.dispatchers kernel namespaces site-watcher site-watcher.db
site-watcher.private urls validators io.sockets.secure.unix.debug
-io.servers.connection db db.tuples sequences ;
+io.servers.connection io.files.temp db db.tuples sequences
+webapps.site-watcher.common webapps.site-watcher.watching
+webapps.site-watcher.spidering ;
QUALIFIED: assocs
IN: webapps.site-watcher
-TUPLE: site-watcher-app < dispatcher ;
-
-CONSTANT: site-list-url URL" $site-watcher-app/"
-
: <main-action> ( -- action )
<page-action>
- [
- logged-in?
- [ URL" $site-watcher-app/list" <redirect> ]
- [ { site-watcher-app "main" } <chloe-content> ] if
- ] >>display ;
-
-: <site-list-action> ( -- action )
- <page-action>
- { site-watcher-app "site-list" } >>template
- [
- ! Silly query
- username watching-sites
- "sites" set-value
- ] >>init
- <protected>
- "list watched sites" >>description ;
-
-: <add-site-action> ( -- action )
- <action>
- [
- { { "url" [ v-url ] } } validate-params
- ] >>validate
- [
- username "url" value watch-site
- site-list-url <redirect>
- ] >>submit
- <protected>
- "add a watched site" >>description ;
-
-: <remove-site-action> ( -- action )
- <action>
- [
- { { "url" [ v-url ] } } validate-params
- ] >>validate
- [
- username "url" value unwatch-site
- site-list-url <redirect>
- ] >>submit
- <protected>
- "remove a watched site" >>description ;
-
-: <check-sites-action> ( -- action )
- <action>
- [
- watch-sites
- site-list-url <redirect>
- ] >>submit
- <protected>
- "check watched sites" >>description ;
+ { site-watcher-app "main" } >>template ;
: <update-notify-action> ( -- action )
<page-action>
: <site-watcher-app> ( -- dispatcher )
site-watcher-app new-dispatcher
<main-action> "" add-responder
- <site-list-action> "list" add-responder
- <add-site-action> "add" add-responder
- <remove-site-action> "remove" add-responder
+ <watch-list-action> "watch-list" add-responder
+ <add-watched-site-action> "add-watch" add-responder
+ <remove-watched-site-action> "remove-watch" add-responder
<check-sites-action> "check" add-responder
+ <spider-list-action> "spider-list" add-responder
+ <add-spidered-site-action> "add-spider" add-responder
+ <remove-spidered-site-action> "remove-spider" add-responder
+ <spider-sites-action> "spider" add-responder
<update-notify-action> "update-notify" add-responder ;
: <login-config> ( responder -- responder' )
8431 >>secure ;
: site-watcher-db ( -- db )
- "resource:test.db" <sqlite-db> ;
+ "test.db" temp-file <sqlite-db> ;
<site-watcher-app>
<login-config>
main-responder set-global
M: site-watcher-app init-user-profile
- drop
+ drop B
"username" value "email" value <account> insert-tuple ;
: init-db ( -- )
site-watcher-db [
- { site account watching-site } [ ensure-table ] each
+ { site account watching-site spidering-site }
+ [ ensure-table ] each
] with-db ;
: start-site-watcher ( -- )
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
-<html>
- <head>
- <title>SiteWatcher</title>
- </head>
- <body>
- <h1>SiteWatcher</h1>
- <h2>It tells you if your web site goes down.</h2>
- <t:call-next-template />
- </body>
-</html>
-
-</t:chloe>
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors furnace.actions furnace.auth
+furnace.redirection html.forms validators webapps.site-watcher.common
+site-watcher.db site-watcher.spider kernel urls sequences ;
+IN: webapps.site-watcher.spidering
+
+CONSTANT: site-list-url URL" $site-watcher-app/spider-list"
+
+: <spider-list-action> ( -- action )
+ <page-action>
+ { site-watcher-app "spider-list" } >>template
+ [
+ ! Silly query
+ username B spidering-sites [ site>> ] map
+ "sites" set-value
+ ] >>init
+ <protected>
+ "list spidered sites" >>description ;
+
+: <add-spidered-site-action> ( -- action )
+ <action>
+ [
+ { { "url" [ v-url ] } } validate-params
+ ] >>validate
+ [
+ username "url" value add-spidered-site
+ site-list-url <redirect>
+ ] >>submit
+ <protected>
+ "add a spidered site" >>description ;
+
+: <remove-spidered-site-action> ( -- action )
+ <action>
+ [
+ { { "url" [ v-url ] } } validate-params
+ ] >>validate
+ [
+ username "url" value remove-spidered-site
+ site-list-url <redirect>
+ ] >>submit
+ <protected>
+ "remove a spidered site" >>description ;
+
+: <spider-sites-action> ( -- action )
+ <action>
+ [
+ spider-sites
+ site-list-url <redirect>
+ ] >>submit
+ <protected>
+ "spider sites" >>description ;
\ No newline at end of file
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
-<h3>Enter your contact details</h3>
-
-<t:form t:action="$site-watcher-app/update-notify">
-<table>
- <tr><th>E-mail:</th><td><t:field t:name="email" t:size="80" /></td></tr>
- <tr><th>Twitter:</th><td><t:field t:name="twitter" t:size="80" /></td></tr>
- <tr><th>SMS:</th><td><t:field t:name="sms" t:size="80" /></td></tr>
-</table>
-<p> <button type="submit">Done</button> </p>
-</t:form>
-
-</t:chloe>
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors furnace.actions furnace.auth
+furnace.redirection html.forms site-watcher site-watcher.db
+validators webapps.site-watcher.common urls ;
+IN: webapps.site-watcher.watching
+
+CONSTANT: site-list-url URL" $site-watcher-app/watch-list"
+
+: <watch-list-action> ( -- action )
+ <page-action>
+ { site-watcher-app "site-list" } >>template
+ [
+ ! Silly query
+ username watching-sites
+ "sites" set-value
+ ] >>init
+ <protected>
+ "list watched sites" >>description ;
+
+: <add-watched-site-action> ( -- action )
+ <action>
+ [
+ { { "url" [ v-url ] } } validate-params
+ ] >>validate
+ [
+ username "url" value watch-site
+ site-list-url <redirect>
+ ] >>submit
+ <protected>
+ "add a watched site" >>description ;
+
+: <remove-watched-site-action> ( -- action )
+ <action>
+ [
+ { { "url" [ v-url ] } } validate-params
+ ] >>validate
+ [
+ username "url" value unwatch-site
+ site-list-url <redirect>
+ ] >>submit
+ <protected>
+ "remove a watched site" >>description ;
+
+: <check-sites-action> ( -- action )
+ <action>
+ [
+ watch-sites
+ site-list-url <redirect>
+ ] >>submit
+ <protected>
+ "check watched sites" >>description ;
\ No newline at end of file
(number constant "integers and floats")
(ratio constant "ratios")
(declaration keyword "declaration words")
+ (ebnf-form constant "EBNF: ... ;EBNF form")
(parsing-word keyword "parsing words")
+ (postpone-body comment "postponed form")
(setter-word function-name "setter words (>>foo)")
(getter-word function-name "getter words (foo>>)")
(stack-effect comment "stack effect specifications")
(defun fuel-font-lock--syntactic-face (state)
(if (nth 3 state) 'factor-font-lock-string
(let ((c (char-after (nth 8 state))))
- (cond ((or (char-equal c ?\ ) (char-equal c ?\n))
+ (cond ((memq c '(?\ ?\n ?E ?P))
(save-excursion
(goto-char (nth 8 state))
(beginning-of-line)
- (cond ((looking-at-p "USING: ")
+ (cond ((looking-at "E") 'factor-font-lock-ebnf-form)
+ ((looking-at "P") 'factor-font-lock-postpone-body)
+ ((looking-at-p "USING: ")
'factor-font-lock-vocabulary-name)
- ((looking-at-p "\\(TUPLE\\|SYMBOLS\\|VARS\\|SINGLETONS\\):")
+ ((looking-at-p
+ "\\(TUPLE\\|SYMBOLS\\|VARS\\|SINGLETONS\\):")
'factor-font-lock-symbol)
((looking-at-p "C-ENUM:\\( \\|\n\\)")
'factor-font-lock-constant)
(,fuel-syntax--alien-function-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
(,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
- (,fuel-syntax--constructor-decl-regex (1 'factor-font-lock-word)
- (2 'factor-font-lock-type-name)
- (3 'factor-font-lock-invalid-syntax nil t))
+ (,fuel-syntax--constructor-decl-regex
+ (1 'factor-font-lock-word)
+ (2 'factor-font-lock-type-name)
+ (3 'factor-font-lock-invalid-syntax nil t))
(,fuel-syntax--typedef-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-type-name)
(3 'factor-font-lock-invalid-syntax nil t))
(let ((name (match-string-no-properties 2))
(body (match-string-no-properties 4))
(end (match-end 0)))
- (list (split-string body nil t) name pos end)))))
+ (list (split-string (or body "") nil t) name pos end)))))
(defun fuel-refactor--find (code to)
(let ((candidate) (result))
(defun fuel-refactor--insert-word (word stack-effect code)
(let ((start (goto-char (fuel-refactor--insertion-point))))
(open-line 1)
- (insert ": " word " " stack-effect "\n" code " ;\n")
+ (insert ": " word " " stack-effect "\n" (or code " ") " ;\n")
(indent-region start (point))
(move-overlay fuel-stack--overlay start (point))))
(delete-overlay fuel-stack--overlay)))
(defun fuel-refactor--extract (begin end)
- (unless (< begin end) (error "No proper region to extract"))
- (let* ((code (buffer-substring begin end))
- (existing (fuel-refactor--reuse-existing code))
- (code-str (or existing (fuel--region-to-string begin end)))
+ (let* ((rp (< begin end))
+ (code (and rp (buffer-substring begin end)))
+ (existing (and code (fuel-refactor--reuse-existing code)))
+ (code-str (and code (or existing (fuel--region-to-string begin end))))
(word (or (car existing) (read-string "New word name: ")))
(stack-effect (or existing
- (fuel-stack--infer-effect code-str)
+ (and code-str (fuel-stack--infer-effect code-str))
(read-string "Stack effect: "))))
- (goto-char begin)
- (delete-region begin end)
- (insert word)
- (indent-region begin (point))
+ (when rp
+ (goto-char begin)
+ (delete-region begin end)
+ (insert word)
+ (indent-region begin (point)))
(save-excursion
(let ((start (or (cadr existing) (point))))
(unless existing
(fuel-refactor--insert-word word stack-effect code))
- (fuel-refactor--extract-other start
- (or (car (cddr existing)) (point))
- code)))))
+ (if rp
+ (fuel-refactor--extract-other start
+ (or (car (cddr existing)) (point))
+ code)
+ (unwind-protect
+ (sit-for fuel-stack-highlight-period)
+ (delete-overlay fuel-stack--overlay)))))))
(defun fuel-refactor-extract-region (begin end)
"Extracts current region as a separate word."
(interactive "r")
- (let ((begin (save-excursion
- (goto-char begin)
- (when (zerop (skip-syntax-backward "w"))
- (skip-syntax-forward "-"))
- (point)))
- (end (save-excursion
- (goto-char end)
- (skip-syntax-forward "w")
- (point))))
- (fuel-refactor--extract begin end)))
+ (if (= begin end)
+ (fuel-refactor--extract begin end)
+ (let ((begin (save-excursion
+ (goto-char begin)
+ (when (zerop (skip-syntax-backward "w"))
+ (skip-syntax-forward "-"))
+ (point)))
+ (end (save-excursion
+ (goto-char end)
+ (skip-syntax-forward "w")
+ (point))))
+ (fuel-refactor--extract begin end))))
(defun fuel-refactor-extract-sexp ()
"Extracts current innermost sexp (up to point) as a separate
"B" "BIN:"
"C:" "C-ENUM:" "C-STRUCT:" "C-UNION:" "CHAR:" "CONSTANT:" "call-next-method"
"DEFER:"
- "ERROR:" "EXCLUDE:"
+ "EBNF:" ";EBNF" "ERROR:" "EXCLUDE:"
"f" "FORGET:" "FROM:" "FUNCTION:"
"GENERIC#" "GENERIC:"
"HELP:" "HEX:" "HOOK:"
;; Strings and chars
("CHAR: \\(\"\\) [^\\\"]*?\\(\"\\)\\([^\\\"]\\|\\\\.\\)*?\\(\"\\)"
(1 "w") (2 "\"") (4 "\""))
- ("\\(CHAR:\\|POSTPONE:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w"))
+ ("\\(CHAR:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w"))
("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)"
(3 "\"") (5 "\""))
("\\_<\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" (1 "\"") (3 "\""))
("\\_<<\\(\"\\)\\_>" (1 "<b"))
("\\_<\\(\"\\)>\\_>" (1 ">b"))
+ ;; postpone
+ ("\\_<POSTPONE:\\( \\).*\\(\n\\)" (1 "<b") (2 ">b"))
;; Multiline constructs
+ ("\\_<\\(E\\)BNF:\\( \\|\n\\)" (1 "<b"))
+ ("\\_<;EBN\\(F\\)\\_>" (1 ">b"))
("\\_<\\(U\\)SING: \\(;\\)" (1 "<b") (2 ">b"))
("\\_<USING:\\( \\)" (1 "<b"))
("\\_<\\(C\\)-ENUM: \\(;\\)" (1 "<b") (2 ">b"))
("\\_<C-ENUM:\\( \\|\n\\)" (1 "<b"))
("\\_<TUPLE: +\\w+? +< +\\w+? *\\( \\|\n\\)\\([^;]\\|$\\)" (1 "<b"))
("\\_<TUPLE: +\\w+? *\\( \\|\n\\)\\([^;<\n]\\|\\_>\\)" (1 "<b"))
- ("\\_<\\(SYMBOLS\\|VARS\\|SINGLETONS\\): *?\\( \\|\n\\)\\([^;\n]\\|\\_>\\)" (2 "<b"))
+ ("\\_<\\(SYMBOLS\\|VARS\\|SINGLETONS\\): *?\\( \\|\n\\)\\([^;\n]\\|\\_>\\)"
+ (2 "<b"))
("\\(\n\\| \\);\\_>" (1 ">b"))
;; Let and lambda:
("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
("\\_<\\(}\\)\\_>" (1 "){"))
;; Parenthesis:
("\\_<\\((\\)\\_>" (1 "()"))
+ ("\\_<call\\((\\)\\_>" (1 "()"))
("\\_<\\()\\)\\_>" (1 ")("))
("\\_<(\\((\\)\\_>" (1 "()"))
("\\_<\\()\\))\\_>" (1 ")("))
ifdef NO_UI
X11_UI_LIBS =
else
- X11_UI_LIBS = -lpango-1.0 -lpangocairo-1.0 -lcairo -lglib-2.0 -lgobject-2.0 -lGL -lGLU -lX11
+ X11_UI_LIBS = -lpango-1.0 -lpangocairo-1.0 -lcairo -lglib-2.0 -lgobject-2.0 -lGL -lX11
endif
# CFLAGS += -fPIC
userenv[CPU_ENV] = tag_object(from_char_string(FACTOR_CPU_STRING));
userenv[OS_ENV] = tag_object(from_char_string(FACTOR_OS_STRING));
userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL));
- userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces);
- userenv[EXECUTABLE_ENV] = (p->executable_path ?
- tag_object(from_native_string(p->executable_path)) : F);
+ userenv[EXECUTABLE_ENV] = (p->executable_path ? tag_object(from_native_string(p->executable_path)) : F);
userenv[ARGS_ENV] = F;
userenv[EMBEDDED_ENV] = F;
gc_off = false;
if(!stage2)
+ {
+ userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces);
do_stage1_init();
+ }
}
/* May allocate memory */
}
F_HEADER h;
- fread(&h,sizeof(F_HEADER),1,file);
+ if(fread(&h,sizeof(F_HEADER),1,file) != 1)
+ fatal_error("Cannot read image header",0);
if(h.magic != IMAGE_MAGIC)
fatal_error("Bad image: magic number check failed",h.magic);
h.userenv[i] = userenv[i];
}
- fwrite(&h,sizeof(F_HEADER),1,file);
+ bool ok = true;
- if(fwrite((void*)tenured->start,h.data_size,1,file) != 1)
- {
- print_string("Save data heap failed: "); print_string(strerror(errno)); nl();
- return false;
- }
-
- if(fwrite(first_block(&code_heap),h.code_size,1,file) != 1)
- {
- print_string("Save code heap failed: "); print_string(strerror(errno)); nl();
- return false;
- }
+ if(fwrite(&h,sizeof(F_HEADER),1,file) != 1) ok = false;
+ if(fwrite((void*)tenured->start,h.data_size,1,file) != 1) ok = false;
+ if(fwrite(first_block(&code_heap),h.code_size,1,file) != 1) ok = false;
+ if(fclose(file)) ok = false;
- if(fclose(file))
+ if(!ok)
{
- print_string("Failed to close image file: "); print_string(strerror(errno)); nl();
- return false;
+ print_string("save-image failed: "); print_string(strerror(errno)); nl();
}
- return true;
+ return ok;
}
void primitive_save_image(void)
}
}
+void primitive_fseek(void)
+{
+ int whence = to_fixnum(dpop());
+ FILE *file = unbox_alien();
+ off_t offset = to_signed_8(dpop());
+
+ switch(whence)
+ {
+ case 0: whence = SEEK_SET; break;
+ case 1: whence = SEEK_CUR; break;
+ case 2: whence = SEEK_END; break;
+ default:
+ critical_error("Bad value for whence",whence);
+ break;
+ }
+
+ if(FSEEK(file,offset,whence) == -1)
+ {
+ io_error();
+
+ /* Still here? EINTR */
+ critical_error("Don't know what to do; EINTR from fseek()?",0);
+ }
+}
+
void primitive_fflush(void)
{
FILE *file = unbox_alien();
void primitive_fputc(void);
void primitive_fwrite(void);
void primitive_fflush(void);
+void primitive_fseek(void);
void primitive_fclose(void);
/* Platform specific primitives */
#define STRNCMP strncmp
#define STRDUP strdup
+#define FSEEK fseeko
+
#define FIXNUM_FORMAT "%ld"
#define CELL_FORMAT "%lu"
#define CELL_HEX_FORMAT "%lx"
#define STRNCMP wcsncmp
#define STRDUP _wcsdup
#define MIN(a,b) ((a)>(b)?(b):(a))
+#define FSEEK fseek
#ifdef WIN64
#define CELL_FORMAT "%Iu"
#if defined(FACTOR_X86)
#include "os-solaris-x86.32.h"
#elif defined(FACTOR_AMD64)
- #incluide "os-solaris-x86.64.h"
+ #include "os-solaris-x86.64.h"
#else
#error "Unsupported Solaris flavor"
#endif
primitive_fputc,
primitive_fwrite,
primitive_fflush,
+ primitive_fseek,
primitive_fclose,
primitive_wrapper,
primitive_clone,
projects / factor.git / commitdiff