HELP: expired?
{ $values { "c-ptr" "an alien, byte array, or " { $link f } } { "?" "a boolean" } }
-{ $description "Tests if the alien is a relic from an earlier session. When an image is loaded, any alien objects which persisted in the image are marked as being expired."
-$nl
-"A byte array is never considered to be expired, whereas passing " { $link f } " always yields true." } ;
+{ $description "Tests if the alien is a relic from an earlier session. A byte array is never considered to have expired, whereas passing " { $link f } " always yields true." } ;
HELP: <displaced-alien> ( displacement c-ptr -- alien )
{ $values { "displacement" "an integer" } { "c-ptr" "an alien, byte array, or " { $link f } } { "alien" "a new alien" } }
{ alien-invoke alien-indirect alien-callback } related-words
+ARTICLE: "alien-expiry" "Alien expiry"
+"When an image is loaded, any alien objects which persisted from the previous session are marked as having expired. This is because the C pointers they contain are almost certainly no longer valid."
+$nl
+"For this reason, the " { $link POSTPONE: ALIEN: } " word should not be used in source files, since loading the source file then saving the image will result in the literal becoming expired. Use " { $link <alien> } " instead, and ensure the word calling " { $link <alien> } " is not declared " { $link POSTPONE: flushable } "."
+{ $subsection expired? } ;
+
ARTICLE: "aliens" "Alien addresses"
"Instances of the " { $link alien } " class represent pointers to C data outside the Factor heap:"
{ $subsection <alien> }
{ $subsection <displaced-alien> }
{ $subsection alien-address }
-{ $subsection expired? }
"Anywhere that a " { $link alien } " instance is accepted, the " { $link f } " singleton may be passed in to denote a null pointer."
$nl
"Usually alien objects do not have to created and dereferenced directly; instead declaring C function parameters and return values as having a pointer type such as " { $snippet "void*" } " takes care of the details."
{ $subsection "syntax-aliens" }
+{ $subsection "alien-expiry" }
"When higher-level abstractions won't do:"
{ $subsection "reading-writing-memory" }
{ $see-also "c-data" "c-types-specs" } ;
USING: help.markup help.syntax strings byte-arrays alien libc
-debugger ;
+debugger io.encodings.string sequences ;
IN: alien.strings
HELP: string>alien
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
$nl
-"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function. If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
+"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
+$nl
+"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
+$nl
+"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
$nl
"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
{ $subsection string>alien }
{ $syntax "ALIEN: address" }
{ $values { "address" "a non-negative integer" } }
{ $description "Creates an alien object at parse time." }
-{ $notes "Alien objects are invalidated between image saves and loads." } ;
+{ $notes "Alien objects are invalidated between image saves and loads, and hence source files should not contain alien literals; this word is for interactive use only. See " { $link "alien-expiry" } " for details." } ;
ARTICLE: "syntax-aliens" "Alien object literal syntax"
{ $subsection POSTPONE: ALIEN: }
classes.private arrays hashtables vectors classes.tuple sbufs
inference.dataflow hashtables.private sequences.private math
classes.tuple.private growable namespaces.private assocs words
-generator command-line vocabs io prettyprint libc compiler.units
-math.order ;
+generator command-line vocabs io io.encodings.string
+prettyprint libc compiler.units math.order ;
IN: bootstrap.compiler
! Don't bring this in when deploying, since it will store a
#! n is positive or zero.
[ dup 0 > ]
[ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
- [ ] unfold nip ;
+ [ ] produce nip ;
: emit-bignum ( n -- )
dup dup 0 < [ neg ] when bignum>seq
[ [ name>> ] compare ] sort >vector\r
[ dup empty? not ]\r
[ dup largest-class >r over delete-nth r> ]\r
- [ ] unfold nip ;\r
+ [ ] produce nip ;\r
\r
: min-class ( class seq -- class/f )\r
over [ classes-intersect? ] curry filter\r
{ $values { "seq" sequence } { "tuple" tuple } }
{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word and the remainder the declared slots."
$nl
-"If the sequence has too many elements, they are ignored, and if it has too few, the remaining slots in the tuple are set to " { $link f } "." }
-{ $errors "Throws an error if the first element of the sequence is not a tuple class word." } ;
+"If the sequence has too few elements, the remaining slots in the tuple are set to their initial values." }
+{ $errors "Throws an error if one of the following occurs:"
+ { $list
+ "the first element of the sequence is not a tuple class word"
+ "the values in the sequence do not satisfy the slot class predicates"
+ "the sequence is too long"
+ }
+} ;
HELP: tuple>array ( tuple -- array )
{ $values { "tuple" tuple } { "array" array } }
[ t ] [ \ error-y tuple-class? ] unit-test
[ f ] [ \ error-y generic? ] unit-test
+
+[ ] [
+ "IN: classes.tuple.tests TUPLE: forget-subclass-test ; TUPLE: forget-subclass-test' < forget-subclass-test ;"
+ <string-reader> "forget-subclass-test" parse-stream
+ drop
+] unit-test
+
+[ ] [ "forget-subclass-test'" "classes.tuple.tests" lookup new "bad-object" set ] unit-test
+
+[ ] [
+ "IN: classes.tuple.tests TUPLE: forget-subclass-test a ;"
+ <string-reader> "forget-subclass-test" parse-stream
+ drop
+] unit-test
[ permute-slots ] [ class>> ] bi
slots>tuple ;
+: outdated-tuple? ( tuple assoc -- ? )
+ over tuple? [
+ [ [ layout-of ] dip key? ]
+ [ drop class "forgotten" word-prop not ]
+ 2bi and
+ ] [ 2drop f ] if ;
+
: update-tuples ( -- )
outdated-tuples get
dup assoc-empty? [ drop ] [
- [
- over tuple?
- [ >r layout-of r> key? ] [ 2drop f ] if
- ] curry instances
+ [ outdated-tuple? ] curry instances
dup [ update-tuple ] map become
] if ;
: heap-pop-all ( heap -- alist )
[ dup heap-empty? not ]
[ dup heap-pop swap 2array ]
- [ ] unfold nip ;
+ [ ] produce nip ;
{ 1 0 } [ [ ] map-children ] must-infer-as
! Corner case
-[ [ [ f dup ] [ dup ] [ ] unfold ] infer ] must-fail
+[ [ [ f dup ] [ dup ] [ ] produce ] infer ] must-fail
[ [ [ f dup ] [ ] [ ] while ] infer ] must-fail
presented associate format ;
: lines ( stream -- seq )
- [ [ readln dup ] [ ] [ drop ] unfold ] with-input-stream ;
+ [ [ readln dup ] [ ] [ drop ] produce ] with-input-stream ;
: contents ( stream -- str )
[
- [ 65536 read dup ] [ ] [ drop ] unfold concat f like
+ [ 65536 read dup ] [ ] [ drop ] produce concat f like
] with-input-stream ;
"Taking a sequence apart into a head and a tail:"
{ $subsection unclip-slice }
{ $subsection cut-slice }
-"A utility for words which use slices as mutable iterators:"
+"A utility for words which use slices as iterators:"
{ $subsection <flat-slice> } ;
ARTICLE: "sequences-combinators" "Sequence combinators"
{ $subsection map }
{ $subsection 2map }
{ $subsection accumulate }
-{ $subsection unfold }
+{ $subsection produce }
"Filtering:"
{ $subsection push-if }
{ $subsection filter } ;
} ;
HELP: slice
-{ $class-description "A virtual sequence which presents a subrange of the elements of an underlying sequence. New instances can be created by calling " { $link <slice> } ". Slices are mutable if the underlying sequence is mutable, and mutating a slice changes the underlying sequence." }
-{ $notes "The slots of a slice should not be changed after the slice has been created, because this can break invariants." } ;
+{ $class-description "A virtual sequence which presents a subrange of the elements of an underlying sequence. New instances can be created by calling " { $link <slice> } "."
+$nl
+"Slices are mutable if the underlying sequence is mutable, and mutating a slice changes the underlying sequence. However, slices cannot be resized after creation." } ;
HELP: check-slice
{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } }
HELP: <flat-slice>
{ $values { "seq" sequence } { "slice" slice } }
{ $description "Outputs a slice with the same elements as " { $snippet "seq" } ", and " { $link slice-from } " equal to 0 and " { $link slice-to } " equal to the length of " { $snippet "seq" } "." }
-{ $notes "Some words create slices then proceed to read and write the " { $link slice-from } " and " { $link slice-to } " slots of the slice. To behave predictably when they are themselves given a slice as input, they apply this word first to get a canonical slice." } ;
+{ $notes "Some words create slices then proceed to read the " { $snippet "to" } " and " { $snippet "from" } " slots of the slice. To behave predictably when they are themselves given a slice as input, they apply this word first to get a canonical slice." } ;
HELP: <slice>
-{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "slice" "a slice" } }
+{ $values { "from" "a non-negative integer" } { "to" "a non-negative integer" } { "seq" sequence } { "slice" slice } }
{ $description "Outputs a new virtual sequence sharing storage with the subrange of elements in " { $snippet "seq" } " with indices starting from and including " { $snippet "m" } ", and up to but not including " { $snippet "n" } "." }
{ $errors "Throws an error if " { $snippet "m" } " or " { $snippet "n" } " is out of bounds." }
{ $notes "Taking the slice of a slice outputs a slice of the underlying sequence of the original slice. Keep this in mind when writing code which depends on the values of " { $link slice-from } " and " { $link slice-to } " being equal to the inputs to this word. The " { $link <flat-slice> } " word might be helpful in such situations." } ;
{ $description "Outputs the greatest element of " { $snippet "seq" } "." }
{ $errors "Throws an error if the sequence is empty." } ;
-HELP: unfold
+HELP: produce
{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "quot" "a quotation with stack effect " { $snippet "( -- obj )" } } { "tail" "a quotation" } { "seq" "a sequence" } }
{ $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence at the end." }
{ $examples
"The following example divides a number by two until we reach zero, and accumulates intermediate results:"
- { $example "USING: kernel math prettyprint sequences ;" "1337 [ dup 0 > ] [ 2/ dup ] [ ] unfold nip ." "{ 668 334 167 83 41 20 10 5 2 1 0 }" }
- "The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link unfold } " call:"
- { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] unfold ." "{ 8 2 2 9 }" }
+ { $example "USING: kernel math prettyprint sequences ;" "1337 [ dup 0 > ] [ 2/ dup ] [ ] produce nip ." "{ 668 334 167 83 41 20 10 5 2 1 0 }" }
+ "The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link produce } " call:"
+ { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] produce ." "{ 8 2 2 9 }" }
} ;
HELP: sigma
: accumulator ( quot -- quot' vec )
V{ } clone [ [ push ] curry compose ] keep ; inline
-: unfold ( pred quot tail -- seq )
+: produce ( pred quot tail -- seq )
swap accumulator >r swap while r> { } like ; inline
: follow ( obj quot -- seq )
- >r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline
+ >r [ dup ] r> [ keep ] curry [ ] produce nip ; inline
: prepare-index ( seq quot -- seq n quot )
>r dup length r> ; inline
--- /dev/null
+William Schlieper
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: kernel continuations sequences namespaces fry ;\r
+\r
+IN: backtrack\r
+\r
+SYMBOL: failure\r
+\r
+: amb ( seq -- elt )\r
+ failure get\r
+ '[ , _ '[ , '[ failure set , , continue-with ] callcc0 ] each\r
+ , continue ] callcc1 ;\r
+\r
+: fail ( -- )\r
+ f amb drop ;\r
+\r
+: require ( ? -- )\r
+ [ fail ] unless ;\r
+\r
--- /dev/null
+Simple non-determinism
\ No newline at end of file
block-if-empty\r
[ dup mailbox-empty? ]\r
[ dup data>> pop-back ]\r
- [ ] unfold nip ;\r
+ [ ] produce nip ;\r
\r
: mailbox-get-all ( mailbox -- array )\r
f mailbox-get-all-timeout ;\r
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
: (read-header) ( -- alist )
- [ read-crlf dup f like ] [ parse-header-line ] [ drop ] unfold ;
+ [ read-crlf dup f like ] [ parse-header-line ] [ drop ] produce ;
: process-header ( alist -- assoc )
f swap [ [ swap or dup ] dip swap ] assoc-map nip
-USING: help.markup help.syntax quotations kernel ;
+USING: help.markup help.syntax quotations kernel irc.messages ;
IN: irc.client
HELP: irc-client "IRC Client object"
{ $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ;
HELP: add-listener "Listening to irc channels/users/etc"
-{ $values { "irc-client" "an irc client object" } { "irc-listener" "an irc listener object" } }
+{ $values { "irc-listener" "an irc listener object" } { "irc-client" "an irc client object" } }
{ $description "Registers " { $snippet "irc-listener" } " with " { $snippet "irc-client" } " and starts listening." } ;
+HELP: remove-listener "Stop an unregister listener"
+{ $values { "irc-listener" "an irc listener object" } { "irc-client" "an irc client object" } }
+{ $description "Unregisters " { $snippet "irc-listener" } " from " { $snippet "irc-client" } " and stops listening. This is how you part from a channel." } ;
+
HELP: terminate-irc "Terminates an irc client"
{ $values { "irc-client" "an irc client object" } }
{ $description "Terminates all activity by " { $link irc-client } " cleaning up resources and notifying listeners." } ;
+HELP: write-message "Sends a message through a listener"
+{ $values { "message" "a string or irc message object" } { "irc-listener" "an irc listener object" } }
+{ $description "Sends " { $snippet "message" } " through " { $snippet "irc-listener" } ". Strings are automatically promoted to privmsg objects." } ;
+
+HELP: read-message "Reads a message from a listener"
+{ $values { "irc-listener" "an irc listener object" } { "message" "an irc message object" } }
+{ $description "Reads " { $snippet "message" } " from " { $snippet "irc-listener" } "." } ;
+
ARTICLE: "irc.client" "IRC Client"
"An IRC Client library"
{ $heading "IRC objects:" }
{ $subsection connect-irc }
{ $subsection terminate-irc }
{ $subsection add-listener }
+{ $subsection remove-listener }
+{ $subsection read-message }
+{ $subsection write-message }
{ $heading "IRC messages" }
"Some of the RFC defined irc messages as objects:"
{ $table
"! Create a channel listener"
"\"#mychannel123\" <irc-channel-listener> mychannel set"
"! Register and start listener (this joins the channel)"
- "bot get mychannel get add-listener"
+ "mychannel get bot get add-listener"
"! Send a message to the channel"
- "\"what's up?\" mychannel get out-messages>> mailbox-put"
+ "\"what's up?\" mychannel get write-message"
"! Read a message from the channel"
- "mychannel get in-messages>> mailbox-get"
+ "mychannel get read-message"
}
;
swap [ 2nip <test-stream> f ] curry >>connect ;
: set-nick ( irc-client nickname -- )
- [ nick>> ] dip >>name drop ;
+ swap profile>> (>>nickname) ;
: with-dummy-client ( quot -- )
rot with-variable ; inline
parse-irc-line f >>timestamp ] unit-test
{ "" } make-client dup "factorbot" set-nick current-irc-client [
- { t } [ irc> nick>> name>> me? ] unit-test
+ { t } [ irc> profile>> nickname>> me? ] unit-test
- { "factorbot" } [ irc> nick>> name>> ] unit-test
+ { "factorbot" } [ irc> profile>> nickname>> ] unit-test
{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
":some.where 001 factorbot :Welcome factorbot"
} make-client
[ connect-irc ] keep 1 seconds sleep
- nick>> name>> ] unit-test
+ profile>> nickname>> ] unit-test
{ join_ "#factortest" } [
{ ":factorbot!n=factorbo@some.where JOIN :#factortest"
! Copyright (C) 2008 Bruno Deferrari, Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators concurrency.mailboxes fry io strings
- io.encodings.8-bit io.sockets kernel namespaces sequences
- splitting threads calendar classes.tuple
- classes ascii assocs accessors destructors continuations ;
+USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
+ accessors destructors namespaces io assocs arrays qualified fry
+ continuations threads strings classes combinators
+ irc.messages irc.messages.private ;
+RENAME: join sequences => sjoin
+EXCLUDE: sequences => join ;
IN: irc.client
! ======================================
: irc-port 6667 ; ! Default irc port
-! "setup" objects
TUPLE: irc-profile server port nickname password ;
C: <irc-profile> irc-profile
-! "live" objects
-TUPLE: nick name channels log ;
-C: <nick> nick
-
-TUPLE: irc-client profile nick stream in-messages out-messages join-messages
+TUPLE: irc-client profile stream in-messages out-messages join-messages
listeners is-running connect reconnect-time ;
: <irc-client> ( profile -- irc-client )
- f V{ } clone V{ } clone <nick>
f <mailbox> <mailbox> <mailbox> H{ } clone f
[ <inet> latin1 <client> ] 15 seconds irc-client boa ;
TUPLE: irc-server-listener < irc-listener ;
TUPLE: irc-channel-listener < irc-listener name password timeout ;
TUPLE: irc-nick-listener < irc-listener name ;
+SYMBOL: +server-listener+
: <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
SINGLETON: irc-connected ! sent when connection is established
UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
-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 name channel ;
-TUPLE: quit < 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 asterisk name ;
-TUPLE: notice < irc-message type ;
-TUPLE: mode < irc-message name channel mode ;
-TUPLE: unhandled < irc-message ;
-
: terminate-irc ( irc-client -- )
[ in-messages>> irc-end swap mailbox-put ]
[ f >>is-running drop ]
: unregister-listener ( name -- ) irc> listeners>> delete-at ;
: to-listener ( message name -- )
- listener> [ f listener> ] unless*
+ listener> [ +server-listener+ listener> ] unless*
[ in-messages>> mailbox-put ] [ drop ] if* ;
! ======================================
! IRC client messages
! ======================================
+GENERIC: irc-message>string ( irc-message -- string )
+
+M: irc-message irc-message>string ( irc-message -- string )
+ [ command>> ]
+ [ parameters>> " " sjoin ]
+ [ trailing>> dup [ CHAR: : prefix ] when ]
+ tri 3array " " sjoin ;
+
: /NICK ( nick -- )
"NICK " irc-write irc-print ;
: /PONG ( text -- )
"PONG " irc-write irc-print ;
-! ======================================
-! Message parsing
-! ======================================
-
-: split-at-first ( seq separators -- before after )
- dupd '[ , member? ] find
- [ cut 1 tail ]
- [ swap ]
- if ;
-
-: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
-
-: 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 ;
-
-: string>irc-message ( string -- object )
- dup split-prefix split-trailing
- [ [ blank? ] trim " " split unclip swap ] dip
- now irc-message boa ;
-
-: parse-irc-line ( string -- message )
- string>irc-message
- dup command>> {
- { "PING" [ \ ping ] }
- { "NOTICE" [ \ notice ] }
- { "001" [ \ logged-in ] }
- { "433" [ \ nick-in-use ] }
- { "JOIN" [ \ join ] }
- { "PART" [ \ part ] }
- { "PRIVMSG" [ \ privmsg ] }
- { "QUIT" [ \ quit ] }
- { "MODE" [ \ mode ] }
- { "KICK" [ \ kick ] }
- [ drop \ unhandled ]
- } case
- [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ;
-
! ======================================
! Server message handling
! ======================================
: me? ( string -- ? )
- irc> nick>> name>> = ;
+ irc> profile>> nickname>> = ;
: irc-message-origin ( irc-message -- name )
dup name>> me? [ prefix>> parse-name ] [ name>> ] if ;
GENERIC: handle-incoming-irc ( irc-message -- )
M: irc-message handle-incoming-irc ( irc-message -- )
- f listener> [ in-messages>> mailbox-put ] [ drop ] if* ;
+ +server-listener+ listener> [ in-messages>> mailbox-put ] [ drop ] if* ;
M: logged-in handle-incoming-irc ( logged-in -- )
- name>> irc> nick>> (>>name) ;
+ name>> irc> profile>> (>>nickname) ;
M: ping handle-incoming-irc ( ping -- )
trailing>> /PONG ;
dup irc-message-origin to-listener ;
M: join handle-incoming-irc ( join -- )
- dup trailing>> listener>
- [ irc> join-messages>> ] unless* mailbox-put ;
+ [ [ prefix>> parse-name me? ] keep and
+ [ irc> join-messages>> mailbox-put ] when* ]
+ [ dup trailing>> to-listener ]
+ bi ;
+
+M: part handle-incoming-irc ( part -- )
+ dup channel>> to-listener ;
M: kick handle-incoming-irc ( kick -- )
[ ] [ channel>> ] [ who>> ] tri me? [ dup unregister-listener ] when
GENERIC: handle-outgoing-irc ( obj -- )
+! M: irc-message handle-outgoing-irc ( irc-message -- )
+! irc-message>string irc-print ;
+
M: privmsg handle-outgoing-irc ( privmsg -- )
- [ name>> ] [ trailing>> ] bi /PRIVMSG ;
+ [ name>> ] [ trailing>> ] bi /PRIVMSG ;
+
+M: part handle-outgoing-irc ( privmsg -- )
+ [ channel>> ] [ trailing>> "" or ] bi /PART ;
! ======================================
! Reader/Writer
2bi ;
GENERIC: (add-listener) ( irc-listener -- )
+
M: irc-channel-listener (add-listener) ( irc-channel-listener -- )
[ [ name>> ] [ password>> ] bi /JOIN ]
[ [ [ drop irc> join-messages>> ]
[ name>> ] keep set+run-listener ;
M: irc-server-listener (add-listener) ( irc-server-listener -- )
- f swap set+run-listener ;
+ +server-listener+ swap set+run-listener ;
+
+GENERIC: (remove-listener) ( irc-listener -- )
+
+M: irc-nick-listener (remove-listener) ( irc-nick-listener -- )
+ name>> unregister-listener ;
+
+M: irc-channel-listener (remove-listener) ( irc-channel-listener -- )
+ [ [ out-messages>> ] [ name>> ] bi
+ \ part new swap >>channel mailbox-put ] keep
+ name>> unregister-listener ;
+
+M: irc-server-listener (remove-listener) ( irc-server-listener -- )
+ drop +server-listener+ unregister-listener ;
: (connect-irc) ( irc-client -- )
[ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
t >>is-running
in-messages>> irc-connected swap mailbox-put ;
+: with-irc-client ( irc-client quot -- )
+ >r current-irc-client r> with-variable ; inline
+
PRIVATE>
: connect-irc ( irc-client -- )
- dup current-irc-client [
+ dup [
[ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi
spawn-irc
- ] with-variable ;
+ ] with-irc-client ;
: add-listener ( irc-listener irc-client -- )
- current-irc-client rot '[ , (add-listener) ] with-variable ;
+ swap '[ , (add-listener) ] with-irc-client ;
+
+: remove-listener ( irc-listener irc-client -- )
+ swap '[ , (remove-listener) ] with-irc-client ;
+
+: write-message ( message irc-listener -- ) out-messages>> mailbox-put ;
+: read-message ( irc-listener -- message ) in-messages>> mailbox-get ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! Copyright (C) 2008 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel fry sequences splitting ascii calendar accessors combinators
+ classes.tuple math.order ;
+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 channel ;
+TUPLE: part < irc-message channel ;
+TUPLE: quit < 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 asterisk name ;
+TUPLE: notice < irc-message type ;
+TUPLE: mode < irc-message name channel mode ;
+TUPLE: unhandled < irc-message ;
+
+<PRIVATE
+! ======================================
+! Message parsing
+! ======================================
+
+: split-at-first ( seq separators -- before after )
+ dupd '[ , member? ] find
+ [ cut 1 tail ]
+ [ swap ]
+ if ;
+
+: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
+
+: 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 ;
+
+: string>irc-message ( string -- object )
+ dup split-prefix split-trailing
+ [ [ blank? ] trim " " split unclip swap ] dip
+ now irc-message boa ;
+
+: parse-irc-line ( string -- message )
+ string>irc-message
+ dup command>> {
+ { "PING" [ \ ping ] }
+ { "NOTICE" [ \ notice ] }
+ { "001" [ \ logged-in ] }
+ { "433" [ \ nick-in-use ] }
+ { "JOIN" [ \ join ] }
+ { "PART" [ \ part ] }
+ { "PRIVMSG" [ \ privmsg ] }
+ { "QUIT" [ \ quit ] }
+ { "MODE" [ \ mode ] }
+ { "KICK" [ \ kick ] }
+ [ drop \ unhandled ]
+ } case
+ [ [ tuple-slots ] [ parameters>> ] bi append ] dip
+ [ all-slots over [ length ] bi@ min head ] keep slots>tuple ;
+
+PRIVATE>
--- /dev/null
+William Schlieper
\ No newline at end of file
--- /dev/null
+A simple IRC client
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: accessors kernel threads combinators concurrency.mailboxes\r
+ sequences strings hashtables splitting fry assocs hashtables\r
+ ui ui.gadgets.panes ui.gadgets.editors ui.gadgets.scrollers\r
+ ui.commands ui.gadgets.frames ui.gestures ui.gadgets.tabs\r
+ io io.styles namespaces irc.client irc.messages ;\r
+\r
+IN: irc.ui\r
+\r
+SYMBOL: client\r
+\r
+TUPLE: ui-window client tabs ;\r
+\r
+: write-color ( str color -- )\r
+ foreground associate format ;\r
+: red { 0.5 0 0 1 } ;\r
+: green { 0 0.5 0 1 } ;\r
+: blue { 0 0 1 1 } ;\r
+\r
+: prefix>nick ( prefix -- nick )\r
+ "!" split first ;\r
+\r
+GENERIC: write-irc ( irc-message -- )\r
+\r
+M: privmsg write-irc\r
+ "<" blue write-color\r
+ [ prefix>> prefix>nick write ] keep\r
+ ">" blue write-color\r
+ " " write\r
+ trailing>> write ;\r
+\r
+M: join write-irc\r
+ "* " green write-color\r
+ prefix>> prefix>nick write\r
+ " has entered the channel." green write-color ;\r
+\r
+M: part write-irc\r
+ "* " red write-color\r
+ [ prefix>> prefix>nick write ] keep\r
+ " has left the channel(" red write-color\r
+ trailing>> write\r
+ ")" red write-color ;\r
+\r
+M: quit write-irc\r
+ "* " red write-color\r
+ [ prefix>> prefix>nick write ] keep\r
+ " has left IRC(" red write-color\r
+ trailing>> write\r
+ ")" red write-color ;\r
+\r
+M: irc-end write-irc\r
+ drop "* You have left IRC" red write-color ;\r
+\r
+M: irc-disconnected write-irc\r
+ drop "* Disconnected" red write-color ;\r
+\r
+M: irc-connected write-irc\r
+ drop "* Connected" green write-color ;\r
+\r
+M: irc-message write-irc\r
+ drop ; ! catch all unimplemented writes, THIS WILL CHANGE \r
+\r
+: print-irc ( irc-message -- )\r
+ write-irc nl ;\r
+\r
+: send-message ( message listener client -- )\r
+ "<" blue write-color\r
+ profile>> nickname>> bold font-style associate format\r
+ ">" blue write-color\r
+ " " write\r
+ over write nl\r
+ out-messages>> mailbox-put ;\r
+\r
+: display ( stream listener -- )\r
+ '[ , [ [ t ]\r
+ [ , read-message print-irc ]\r
+ [ ] while ] with-output-stream ] "ircv" spawn drop ;\r
+\r
+: <irc-pane> ( listener -- pane )\r
+ <scrolling-pane>\r
+ [ <pane-stream> swap display ] keep ;\r
+\r
+TUPLE: irc-editor outstream listener client ;\r
+\r
+: <irc-editor> ( pane listener client -- editor )\r
+ [ <editor> irc-editor construct-editor\r
+ swap >>listener swap <pane-stream> >>outstream\r
+ ] dip client>> >>client ;\r
+\r
+: editor-send ( irc-editor -- )\r
+ { [ outstream>> ]\r
+ [ editor-string ]\r
+ [ listener>> ]\r
+ [ client>> ]\r
+ [ "" swap set-editor-string ] } cleave\r
+ '[ , , , send-message ] with-output-stream ;\r
+\r
+irc-editor "general" f {\r
+ { T{ key-down f f "RET" } editor-send }\r
+ { T{ key-down f f "ENTER" } editor-send }\r
+} define-command-map\r
+\r
+: irc-page ( name pane editor tabbed -- )\r
+ [ [ <scroller> @bottom frame, ! editor\r
+ <scroller> @center frame, ! pane\r
+ ] make-frame swap ] dip add-page ;\r
+\r
+: join-channel ( name ui-window -- )\r
+ [ dup <irc-channel-listener> ] dip\r
+ [ client>> add-listener ]\r
+ [ drop <irc-pane> dup ]\r
+ [ [ <irc-editor> ] keep ] 2tri\r
+ tabs>> irc-page ;\r
+\r
+: irc-window ( ui-window -- )\r
+ [ tabs>> ]\r
+ [ client>> profile>> server>> ] bi\r
+ open-window ;\r
+\r
+: ui-connect ( profile -- ui-window )\r
+ <irc-client> ui-window new over >>client swap\r
+ [ connect-irc ]\r
+ [ listeners>> +server-listener+ swap at <irc-pane> <scroller>\r
+ "Server" associate <tabbed> >>tabs ] bi ;\r
+\r
+: freenode-connect ( -- ui-window )\r
+ "irc.freenode.org" 8001 "factor-irc" f\r
+ <irc-profile> ui-connect [ irc-window ] keep ;\r
! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
: factoradic ( n -- factoradic )
- 0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] unfold reverse 2nip ;
+ 0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] produce reverse 2nip ;
: (>permutation) ( seq n -- seq )
[ [ dupd >= [ 1+ ] when ] curry map ] keep prefix ;
: topological-sort ( seq quot -- newseq )
>r >vector [ dup empty? not ] r>
[ dupd maximal-element >r over delete-nth r> ] curry
- [ ] unfold nip ; inline
+ [ ] produce nip ; inline
: classes< ( seq1 seq2 -- lt/eq/gt )
[
"B" [ drop t ] satisfy [ 66 >= ] semantic parse
] unit-test
+{ f } [ \ + T{ parser f f f } equal? ] unit-test
\ No newline at end of file
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces math assocs shuffle debugger io
vectors arrays math.parser math.order vectors combinators combinators.lib
- sets unicode.categories compiler.units parser
+ combinators.short-circuit classes sets unicode.categories compiler.units parser
words quotations effects memoize accessors locals effects splitting ;
IN: peg
TUPLE: parse-error position messages ;
TUPLE: parser peg compiled id ;
-M: parser equal? [ id>> ] bi@ = ;
+M: parser equal? { [ [ class ] bi@ = ] [ [ id>> ] bi@ = ] } 2&& ;
M: parser hashcode* id>> hashcode* ;
C: <parse-result> parse-result
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+USING: help.syntax help.markup kernel arrays assocs ;
+IN: persistent-heaps
+
+HELP: <persistent-heap>
+{ $values { "heap" "a persistent heap" } }
+{ $description "Creates a new persistent heap" } ;
+
+HELP: <singleton-heap>
+{ $values { "value" object } { "prio" "a priority" } { "heap" "a persistent heap" } }
+{ $description "Creates a new persistent heap consisting of one object with the given priority." } ;
+
+HELP: pheap-empty?
+{ $values { "heap" "a persistent heap" } { "?" "a boolean" } }
+{ $description "Returns true if this is an empty persistent heap." } ;
+
+HELP: pheap-peek
+{ $values { "heap" "a persistent heap" } { "value" "an object in the heap" } { "prio" "the minimum priority" } }
+{ $description "Gets the object in the heap with minumum priority." } ;
+
+HELP: pheap-push
+{ $values { "heap" "a persistent heap" } { "value" object } { "prio" "a priority" } { "newheap" "a new persistent heap" } }
+{ $description "Creates a new persistent heap also containing the given object of the given priority." } ;
+
+HELP: pheap-pop*
+{ $values { "heap" "a persistent heap" } { "newheap" "a new persistent heap" } }
+{ $description "Creates a new persistent heap with the minimum element removed." } ;
+
+HELP: pheap-pop
+{ $values { "heap" "a persistent heap" } { "newheap" "a new persistent heap" } { "value" object } { "prio" "a priority" } }
+{ $description "Creates a new persistent heap with the minimum element removed, returning that element and its priority." } ;
+
+HELP: assoc>pheap
+{ $values { "assoc" assoc } { "heap" "a persistent heap" } }
+{ $description "Creates a new persistent heap from an associative mapping whose keys are the entries in the heap and whose values are the associated priorities." } ;
+
+HELP: pheap>alist
+{ $values { "heap" "a persistent heap" } { "alist" "an association list" } }
+{ $description "Creates an association list whose keys are the entries in the heap and whose values are the associated priorities. It is in sorted order by priority. This does not modify the heap." } ;
+
+HELP: pheap>values
+{ $values { "heap" "a persistent heap" } { "values" array } }
+{ $description "Creates an an array of all of the values in the heap, in sorted order by priority. This does not modify the heap." } ;
+
+ARTICLE: "persistent-heaps" "Persistent heaps"
+"This vocabulary implements persistent minheaps, aka priority queues. They are purely functional and support efficient O(log n) operations of pushing and popping, with O(1) time access to the minimum element. To create heaps, use the following words:"
+{ $subsection <persistent-heap> }
+{ $subsection <singleton-heap> }
+"To manipulate them:"
+{ $subsection pheap-peek }
+{ $subsection pheap-push }
+{ $subsection pheap-pop }
+{ $subsection pheap-pop* }
+{ $subsection pheap-empty? }
+{ $subsection assoc>pheap }
+{ $subsection pheap>alist }
+{ $subsection pheap>values } ;
+
+ABOUT: "persistent-heaps"
--- /dev/null
+USING: persistent-heaps tools.test ;
+IN: persistent-heaps.tests
+
+: test-input
+ { { "hello" 3 } { "goodbye" 2 } { "whatever" 5 }
+ { "foo" 1 } { "bar" -1 } { "baz" -7 } { "bing" 0 } } ;
+
+[
+ { { "baz" -7 } { "bar" -1 } { "bing" 0 } { "foo" 1 }
+ { "goodbye" 2 } { "hello" 3 } { "whatever" 5 } }
+] [ test-input assoc>pheap pheap>alist ] unit-test
--- /dev/null
+USING: kernel accessors multi-methods locals combinators math arrays
+assocs namespaces sequences ;
+IN: persistent-heaps
+! These are minheaps
+
+<PRIVATE
+TUPLE: branch value prio left right ;
+TUPLE: empty-heap ;
+
+PREDICATE: singleton-heap < branch
+ [ left>> ] [ right>> ] bi [ empty-heap? ] both? ;
+
+C: <branch> branch
+: >branch< ( branch -- value prio left right )
+ { [ value>> ] [ prio>> ] [ left>> ] [ right>> ] } cleave ;
+PRIVATE>
+
+: <persistent-heap> ( -- heap ) T{ empty-heap } ;
+
+: <singleton-heap> ( value prio -- heap )
+ <persistent-heap> <persistent-heap> <branch> ;
+
+: pheap-empty? ( heap -- ? ) empty-heap? ;
+
+: empty-pheap ( -- * )
+ "Attempt to delete from an empty heap" throw ;
+
+<PRIVATE
+: remove-left ( heap -- value prio newheap )
+ dup [ left>> ] [ right>> ] bi [ pheap-empty? ] both?
+ [ [ value>> ] [ prio>> ] bi <persistent-heap> ]
+ [ >branch< swap remove-left -rot [ <branch> ] 2dip rot ] if ;
+
+: both-with? ( obj a b quot -- ? )
+ swap >r with r> swap both? ; inline
+
+GENERIC: sift-down ( value prio left right -- heap )
+
+METHOD: sift-down { empty-heap empty-heap } <branch> ;
+
+METHOD: sift-down { singleton-heap empty-heap }
+ 3dup drop prio>> <= [ <branch> ] [
+ drop -rot [ [ value>> ] [ prio>> ] bi ] 2dip
+ <singleton-heap> <persistent-heap> <branch>
+ ] if ;
+
+:: reroot-left ( value prio left right -- heap )
+ left value>> left prio>>
+ value prio left left>> left right>> sift-down
+ right <branch> ;
+
+:: reroot-right ( value prio left right -- heap )
+ right value>> right prio>> left
+ value prio right left>> right right>> sift-down
+ <branch> ;
+
+METHOD: sift-down { branch branch }
+ 3dup [ prio>> <= ] both-with? [ <branch> ] [
+ 2dup [ prio>> ] bi@ <= [ reroot-left ] [ reroot-right ] if
+ ] if ;
+PRIVATE>
+
+GENERIC: pheap-peek ( heap -- value prio )
+M: empty-heap pheap-peek empty-pheap ;
+M: branch pheap-peek [ value>> ] [ prio>> ] bi ;
+
+GENERIC: pheap-push ( value prio heap -- newheap )
+
+M: empty-heap pheap-push
+ drop <singleton-heap> ;
+
+<PRIVATE
+: push-top ( value prio heap -- newheap )
+ [ [ value>> ] [ prio>> ] [ right>> ] tri pheap-push ]
+ [ left>> ] bi <branch> ;
+
+: push-in ( value prio heap -- newheap )
+ [ 2nip [ value>> ] [ prio>> ] bi ]
+ [ right>> pheap-push ]
+ [ 2nip left>> ] 3tri <branch> ;
+PRIVATE>
+
+M: branch pheap-push
+ 2dup prio>> <= [ push-top ] [ push-in ] if ;
+
+: pheap-pop* ( heap -- newheap )
+ dup pheap-empty? [ empty-pheap ] [
+ dup left>> pheap-empty?
+ [ drop <persistent-heap> ]
+ [ [ left>> remove-left ] keep right>> swap sift-down ] if
+ ] if ;
+
+: pheap-pop ( heap -- newheap value prio )
+ [ pheap-pop* ] [ pheap-peek ] bi ;
+
+: assoc>pheap ( assoc -- heap ) ! Assoc is value => prio
+ <persistent-heap> swap [ rot pheap-push ] assoc-each ;
+
+: pheap>alist ( heap -- alist )
+ [ dup pheap-empty? not ] [ pheap-pop 2array ] [ ] produce nip ;
+
+: pheap>values ( heap -- seq ) pheap>alist keys ;
--- /dev/null
+Datastructure for functional peristent heaps, from ML for the Working Programmer
--- /dev/null
+collections
! -------------------
: fib-upto* ( n -- seq )
- 0 1 [ pick over >= ] [ tuck + dup ] [ ] unfold 3nip
+ 0 1 [ pick over >= ] [ tuck + dup ] [ ] produce 3nip
but-last-slice { 0 1 } prepend ;
: euler002a ( -- answer )
: first-days ( end-date start-date -- days )
[ 2dup after=? ]
[ dup 1 months time+ swap day-of-week ]
- [ ] unfold 2nip ;
+ [ ] produce 2nip ;
PRIVATE>
dup 1+ * 2/ ; inline
: >base7 ( x -- y )
- [ dup 0 > ] [ 7 /mod ] [ ] unfold nip ;
+ [ dup 0 > ] [ 7 /mod ] [ ] produce nip ;
: (use-digit) ( prev x index -- next )
[ [ 1+ * ] [ sum-1toN 7 sum-1toN ] bi ] dip ^ * + ;
] if ;
: number>digits ( n -- seq )
- [ dup zero? not ] [ 10 /mod ] [ ] unfold reverse nip ;
+ [ dup zero? not ] [ 10 /mod ] [ ] produce reverse nip ;
: nth-triangle ( n -- n )
dup 1+ * 2 / ;
HELP: gadget-child
{ $values { "gadget" gadget } { "child" gadget } }
-{ $description "Outputs the first child of the gadget. Typicallykernel.private this word is used with gadgets which are known to have an only child." } ;
+{ $description "Outputs the first child of the gadget. Typically this word is used with gadgets which are known to have an only child." } ;
HELP: nth-gadget
{ $values { "n" "a non-negative integer" } { "gadget" gadget } { "child" gadget } }
--- /dev/null
+William Schlieper
\ No newline at end of file
--- /dev/null
+Tabbed windows
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 William Schlieper\r
+! See http://factorcode.org/license.txt for BSD license.\r
+\r
+USING: accessors kernel fry math math.vectors sequences arrays vectors assocs\r
+ hashtables models models.range models.compose combinators\r
+ ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs\r
+ ui.gadgets.incremental ui.gadgets.viewports ui.gadgets.books ;\r
+\r
+IN: ui.gadgets.tabs\r
+\r
+TUPLE: tabbed names model toggler content ;\r
+\r
+DEFER: (del-page)\r
+\r
+: add-toggle ( model n name toggler -- )\r
+ [ [ gadget-parent '[ , , , (del-page) ] "X" swap\r
+ <bevel-button> @right frame, ] 3keep \r
+ [ swapd <toggle-button> @center frame, ] dip ] make-frame\r
+ swap add-gadget ;\r
+\r
+: redo-toggler ( tabbed -- )\r
+ [ names>> ] [ model>> ] [ toggler>> ] tri\r
+ [ clear-gadget ] keep\r
+ [ [ length ] keep ] 2dip\r
+ '[ , _ _ , add-toggle ] 2each ;\r
+\r
+: refresh-book ( tabbed -- )\r
+ model>> [ ] change-model ;\r
+\r
+: (del-page) ( n name tabbed -- )\r
+ { [ [ remove ] change-names redo-toggler ]\r
+ [ dupd [ names>> length ] [ model>> ] bi\r
+ [ [ = ] keep swap [ 1- ] when\r
+ [ < ] keep swap [ 1- ] when ] change-model ]\r
+ [ content>> nth-gadget unparent ]\r
+ [ refresh-book ]\r
+ } cleave ;\r
+\r
+: add-page ( page name tabbed -- )\r
+ [ names>> push ] 2keep\r
+ [ [ model>> swap ]\r
+ [ names>> length 1 - swap ]\r
+ [ toggler>> ] tri add-toggle ]\r
+ [ content>> add-gadget ]\r
+ [ refresh-book ] tri ;\r
+\r
+: del-page ( name tabbed -- )\r
+ [ names>> index ] 2keep (del-page) ;\r
+\r
+: <tabbed> ( assoc -- tabbed )\r
+ tabbed new\r
+ [ <pile> 1 >>fill g-> (>>toggler) @left frame,\r
+ [ keys >vector g (>>names) ]\r
+ [ values 0 <model> [ <book> g-> (>>content) @center frame, ] keep ] bi\r
+ g swap >>model redo-toggler ] build-frame ;\r
[ EnumClipboardFormats win32-error dup dup 0 > ]
[ ]
[ drop ]
- unfold nip ;
+ produce nip ;
: with-clipboard ( quot -- )
f OpenClipboard win32-error=0/f
projects / factor.git / commitdiff