Factorbot example, moved image bootstrap test to benchmarks suite
Slava Pestov
parent
06fd239a6f
commit
74dc918e29
|
|
@ -0,0 +1,99 @@
|
|||
! Simple IRC bot written in Factor.
|
||||
|
||||
IN: factorbot
|
||||
USING: hashtables http io kernel math namespaces prettyprint
|
||||
sequences strings words ;
|
||||
|
||||
SYMBOL: irc-stream
|
||||
SYMBOL: nickname
|
||||
SYMBOL: speaker
|
||||
SYMBOL: receiver
|
||||
|
||||
: irc-write ( s -- ) irc-stream get stream-write ;
|
||||
: irc-print ( s -- )
|
||||
irc-stream get stream-print
|
||||
irc-stream get stream-flush ;
|
||||
|
||||
: nick ( nick -- )
|
||||
dup nickname set "NICK " irc-write irc-print ;
|
||||
|
||||
: login ( nick -- )
|
||||
dup nick
|
||||
"USER " irc-write irc-write
|
||||
" hostname servername :irc.factor" irc-print ;
|
||||
|
||||
: connect ( server -- ) 6667 <client> irc-stream set ;
|
||||
|
||||
: disconnect ( -- ) irc-stream get stream-close ;
|
||||
|
||||
: join ( chan -- )
|
||||
"JOIN " irc-write irc-print ;
|
||||
|
||||
GENERIC: handle-irc
|
||||
PREDICATE: string privmsg "PRIVMSG" swap subseq? ;
|
||||
|
||||
M: string handle-irc ( line -- )
|
||||
drop ( print flush ) ;
|
||||
|
||||
: parse-privmsg ( line -- text )
|
||||
":" ?head drop
|
||||
"!" split1 swap speaker set
|
||||
"PRIVMSG " split1 nip
|
||||
" " split1 swap receiver set
|
||||
":" ?head drop ;
|
||||
|
||||
M: privmsg handle-irc ( line -- )
|
||||
parse-privmsg
|
||||
" " split1 swap
|
||||
[ "factorbot-commands" ] search dup
|
||||
[ execute ] [ 2drop ] ifte ;
|
||||
|
||||
: say ( line nick -- )
|
||||
"PRIVMSG " irc-write irc-write " :" irc-write irc-print ;
|
||||
|
||||
: respond ( line -- )
|
||||
receiver get nickname get = speaker receiver ? get say ;
|
||||
|
||||
: word-string ( word -- string )
|
||||
[
|
||||
"IN: " % dup word-vocabulary %
|
||||
" " % dup definer word-name %
|
||||
" " % dup word-name %
|
||||
"stack-effect" word-prop [ " (" % % ")" % ] when*
|
||||
] make-string ;
|
||||
|
||||
: word-url ( word -- url )
|
||||
[
|
||||
"http://factor.modalwebserver.co.nz/responder/browser/?vocab=" %
|
||||
dup word-vocabulary url-encode %
|
||||
"&word=" %
|
||||
word-name url-encode %
|
||||
] make-string ;
|
||||
|
||||
: irc-loop ( -- )
|
||||
irc-stream get stream-readln
|
||||
[ handle-irc irc-loop ] when* ;
|
||||
|
||||
: factorbot
|
||||
"irc.freenode.net" connect
|
||||
"factorbot" login
|
||||
"#concatenative" join
|
||||
irc-loop ;
|
||||
|
||||
IN: factorbot-commands
|
||||
|
||||
: see ( text -- )
|
||||
dup vocabs [ vocab ?hash ] map-with [ ] subset
|
||||
dup empty? [
|
||||
drop
|
||||
"Sorry, I couldn't find anything for " swap append respond
|
||||
] [
|
||||
nip [
|
||||
dup word-string " -- " rot word-url append3 respond
|
||||
] each-with
|
||||
] ifte ;
|
||||
|
||||
: quit ( text -- )
|
||||
drop speaker "slava" = [ disconnect ] when ;
|
||||
|
||||
factorbot
|
||||
|
|
@ -1,98 +0,0 @@
|
|||
! A simple IRC client written in Factor.
|
||||
|
||||
IN: irc
|
||||
USING: kernel lists math namespaces io strings threads words ;
|
||||
|
||||
SYMBOL: irc-stream
|
||||
SYMBOL: channels
|
||||
SYMBOL: channel
|
||||
SYMBOL: nickname
|
||||
|
||||
: irc-write ( s -- ) irc-stream get stream-write ;
|
||||
: irc-print ( s -- )
|
||||
irc-stream get stream-print
|
||||
irc-stream get stream-flush ;
|
||||
|
||||
: nick ( nick -- )
|
||||
dup nickname set "NICK " irc-write irc-print ;
|
||||
|
||||
: login ( nick -- )
|
||||
dup nick
|
||||
"USER " irc-write irc-write
|
||||
" hostname servername :irc.factor" irc-print ;
|
||||
|
||||
: connect ( server -- ) 6667 <client> irc-stream set ;
|
||||
|
||||
: write-highlighted ( line -- )
|
||||
dup nickname get index-of -1 =
|
||||
f [ [[ "ansi-fg" "3" ]] ] ? write-attr ;
|
||||
|
||||
: extract-nick ( line -- nick )
|
||||
"!" split1 drop ;
|
||||
|
||||
: write-nick ( line -- )
|
||||
"!" split1 drop [ [[ "bold" t ]] ] write-attr ;
|
||||
|
||||
GENERIC: irc-display
|
||||
PREDICATE: string privmsg "PRIVMSG" index-of -1 > ;
|
||||
PREDICATE: string action "ACTION" index-of -1 > ;
|
||||
|
||||
M: string irc-display ( line -- )
|
||||
print ;
|
||||
|
||||
M: privmsg irc-display ( line -- )
|
||||
"PRIVMSG" split1 >r write-nick r>
|
||||
write-highlighted terpri flush ;
|
||||
|
||||
! Doesn't look good
|
||||
! M: action irc-display ( line -- )
|
||||
! " * " write
|
||||
! "ACTION" split1 >r write-nick r>
|
||||
! write-highlighted terpri flush ;
|
||||
|
||||
: in-loop ( -- )
|
||||
irc-stream get stream-readln [ irc-display in-loop ] when* ;
|
||||
|
||||
: input-thread ( -- ) [ in-loop ] in-thread ;
|
||||
: disconnect ( -- ) irc-stream get stream-close ;
|
||||
|
||||
: command ( line -- )
|
||||
#! IRC /commands are just words.
|
||||
" " split1 swap [
|
||||
"irc" "listener" "parser" "scratchpad"
|
||||
] search execute ;
|
||||
|
||||
: (msg) ( line nick -- )
|
||||
"PRIVMSG " irc-write irc-write " :" irc-write irc-print ;
|
||||
|
||||
: say ( line -- )
|
||||
channel get [ (msg) ] [ "No channel." print ] ifte* ;
|
||||
|
||||
: talk ( input -- ) "/" ?string-head [ command ] [ say ] ifte ;
|
||||
: talk-loop ( -- ) read-line [ talk talk-loop ] when* ;
|
||||
|
||||
: irc ( nick server -- )
|
||||
[
|
||||
channels off
|
||||
channel off
|
||||
connect
|
||||
login
|
||||
input-thread
|
||||
talk-loop
|
||||
disconnect
|
||||
] with-scope ;
|
||||
|
||||
! /commands
|
||||
: join ( chan -- )
|
||||
dup channels [ cons ] change
|
||||
dup channel set
|
||||
"JOIN " irc-write irc-print ;
|
||||
|
||||
: leave ( chan -- )
|
||||
dup channels [ remove ] change
|
||||
channels get dup [ car ] when channel set
|
||||
"PART " irc-write irc-print ;
|
||||
|
||||
: msg ( line -- ) " " split1 swap (msg) ;
|
||||
: me ( line -- ) "\u0001ACTION " swap "\u0001" cat3 say ;
|
||||
: quit ( line -- ) drop disconnect ;
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
IN: temporary
|
||||
USING: generic image kernel math namespaces parser test ;
|
||||
|
||||
[
|
||||
boot-quot off
|
||||
"/library/bootstrap/boot-stage1.factor" run-resource
|
||||
] with-image drop
|
||||
|
||||
[ fixnum ] [ 4 class ] unit-test
|
||||
|
|
@ -1,3 +1,4 @@
|
|||
IN: temporary
|
||||
USE: test
|
||||
USE: image
|
||||
USE: namespaces
|
||||
|
|
@ -25,10 +26,3 @@ USE: math
|
|||
[
|
||||
[ image-magic 8 >be write ] string-out
|
||||
] unit-test
|
||||
|
||||
[
|
||||
boot-quot off
|
||||
"/library/bootstrap/boot-stage1.factor" run-resource
|
||||
] with-image drop
|
||||
|
||||
[ fixnum ] [ 4 class ] unit-test
|
||||
|
|
|
|||
|
|
@ -103,6 +103,7 @@ SYMBOL: failures
|
|||
"benchmark/continuations" "benchmark/ack"
|
||||
"benchmark/hashtables" "benchmark/strings"
|
||||
"benchmark/vectors" "benchmark/prettyprint"
|
||||
"benchmark/image"
|
||||
] run-tests ;
|
||||
|
||||
: compiler-tests
|
||||
|
|
|
|||
|
|
@ -33,20 +33,17 @@ SYMBOL: vocabularies
|
|||
all-words swap subset word-sort ; inline
|
||||
|
||||
: word-subset-with ( obj pred -- list | pred: obj word -- ? )
|
||||
all-words swap subset-with ; inline
|
||||
all-words swap subset-with word-sort ; inline
|
||||
|
||||
: recrossref ( -- )
|
||||
#! Update word cross referencing information.
|
||||
global [ <namespace> crossref set ] bind
|
||||
[ add-crossref ] each-word ;
|
||||
|
||||
: (search) ( name vocab -- word )
|
||||
vocab dup [ hash ] [ 2drop f ] ifte ;
|
||||
|
||||
: search ( name list -- word )
|
||||
#! Search for a word in a list of vocabularies.
|
||||
dup [
|
||||
2dup car (search) [ nip ] [ cdr search ] ?ifte
|
||||
2dup car vocab ?hash [ nip ] [ cdr search ] ?ifte
|
||||
] [
|
||||
2drop f
|
||||
] ifte ;
|
||||
|
|
@ -70,7 +67,7 @@ SYMBOL: vocabularies
|
|||
#! Create a new word in a vocabulary. If the vocabulary
|
||||
#! already contains the word, the existing instance is
|
||||
#! returned.
|
||||
2dup (search) [
|
||||
2dup vocab ?hash [
|
||||
nip
|
||||
dup f "documentation" set-word-prop
|
||||
dup f "stack-effect" set-word-prop
|
||||
|
|
|
|||
Loading…
Reference in New Issue