Factorbot example, moved image bootstrap test to benchmarks suite

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 <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

examples/irc.factor

@@ -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 ;

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

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

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

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 [ <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