diff --git a/examples/factorbot.factor b/examples/factorbot.factor new file mode 100644 index 0000000000..4fa260c724 --- /dev/null +++ b/examples/factorbot.factor @@ -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 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 diff --git a/examples/irc.factor b/examples/irc.factor deleted file mode 100644 index ba53ff5c16..0000000000 --- a/examples/irc.factor +++ /dev/null @@ -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 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 ; diff --git a/library/test/benchmark/image.factor b/library/test/benchmark/image.factor new file mode 100644 index 0000000000..2a06f3a2e4 --- /dev/null +++ b/library/test/benchmark/image.factor @@ -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 diff --git a/library/test/image.factor b/library/test/image.factor index 25d1a9a1ec..7793387719 100644 --- a/library/test/image.factor +++ b/library/test/image.factor @@ -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 diff --git a/library/test/test.factor b/library/test/test.factor index cfb9bbd201..c00f80fdbe 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -103,6 +103,7 @@ SYMBOL: failures "benchmark/continuations" "benchmark/ack" "benchmark/hashtables" "benchmark/strings" "benchmark/vectors" "benchmark/prettyprint" + "benchmark/image" ] run-tests ; : compiler-tests diff --git a/library/vocabularies.factor b/library/vocabularies.factor index 5cf5827f13..a1ed9e36ec 100644 --- a/library/vocabularies.factor +++ b/library/vocabularies.factor @@ -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 [ 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