IRC bot fixes, UI fix, canvas gadget example

examples/canvas.factor

@@ -0,0 +1,77 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+
+! This example only runs in the UI listener.
+
+! Pass with-canvas a quotation calling these words:
+! - turn-by
+! - move-by
+! - plot-point
+! - line-to
+! - new-pen
+
+! plot-string doesn't yet work.
+
+! other GL calls can be made, but be careful.
+
+IN: gadgets-canvas
+USING: arrays errors freetype gadgets gadgets-labels
+gadgets-layouts gadgets-panes gadgets-theme generic kernel math
+namespaces opengl sequences styles ;
+
+SYMBOL: canvas-font
+
+{ "monospaced" plain 12 } canvas-font set-global
+
+: turn-by ( angle -- ) 0 0 1 glRotated ;
+
+: move-by ( distance -- ) 0 0 glTranslated ;
+
+: plot-point ( -- )
+    GL_POINTS [ 0 0 0 glVertex3d ] do-state ;
+
+: line-to ( distance -- )
+    dup
+    GL_LINES [ 0 0 0 glVertex3d 0 0 glVertex3d ] do-state
+    move-by ;
+
+: plot-string ( string -- )
+    canvas-font get open-font swap draw-string ;
+
+: new-pen ( quot -- ) GL_MODELVIEW swap do-matrix ; inline
+
+TUPLE: canvas quot id ;
+
+C: canvas ( quot -- )
+    dup delegate>gadget [ set-canvas-quot ] keep ;
+
+M: canvas add-notify* ( gadget -- )
+    canvas-quot GL_COMPILE [ with-scope ] make-dlist
+    swap set-canvas-id ;
+
+M: canvas draw-gadget* ( gadget -- )
+    GL_MODELVIEW [
+        dup rect-dim 2 v/n gl-translate
+        canvas-id glCallList
+    ] do-matrix ;
+
+: with-canvas ( size quot -- )
+    <canvas> dup solid-boundary [ set-gadget-dim ] keep gadget. ;
+
+: random-walk ( n -- )
+    [ 2 random-int 1/2 - 180 * turn-by 10 line-to ] times ;
+
+: regular-polygon ( sides n -- )
+    [ 360 swap / ] keep [ over line-to dup turn-by ] times 2drop ;
+
+: random-color
+    4 [ drop 255 random-int 255 /f ] map gl-color ;
+
+: turtle-test
+    { 800 800 0 } [
+        36 [
+            random-color
+            10 line-to
+            10 turn-by [ 60 17 regular-polygon ] new-pen
+        ] times
+    ] with-canvas ;

examples/factorbot.factor

@@ -1,10 +1,9 @@
 ! Simple IRC bot written in Factor.
 
 ! Load the HTTP server first (contrib/httpd/load.factor).
-! This file uses the url-encode and url-decode words.
 
-USING: errors generic hashtables http io kernel math namespaces
-parser prettyprint sequences strings unparser words ;
+USING: errors generic hashtables html http io kernel math
+namespaces parser prettyprint sequences strings words ;
 IN: factorbot
 
 SYMBOL: irc-stream
@@ -48,7 +47,7 @@ M: object handle-irc ( line -- )
 M: privmsg handle-irc ( line -- )
     parse-privmsg
     " " split1 swap
-    [ "factorbot-commands" ] search dup
+    "factorbot-commands" lookup dup
     [ execute ] [ 2drop ] if ;
 
 M: ping handle-irc ( line -- )
@@ -63,25 +62,13 @@ M: ping handle-irc ( line -- )
 : 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 ;
-
-: word-url ( word -- url )
-    [
-        "http://factor.modalwebserver.co.nz/responder/browser/?vocab=" %
-        dup word-vocabulary url-encode %
-        "&word=" %
-        word-name url-encode %
-    ] "" make ;
-
 : irc-loop ( -- )
+    [
         irc-stream get stream-readln
-    [ dup print flush parse-irc irc-loop ] when* ;
+        [ dup print flush parse-irc irc-loop ] when*
+    ] [
+        irc-stream get stream-close
+    ] cleanup ;
 
 : factorbot
     "irc.freenode.net" connect
@@ -89,6 +76,11 @@ M: ping handle-irc ( line -- )
     "#concatenative" join
     irc-loop ;
 
+: factorbot-loop [ factorbot ] try factorbot-loop ;
+
+: multiline-respond ( string -- )
+    <string-reader> lines [ respond ] each ;
+
 IN: factorbot-commands
 
 : see ( text -- )
@@ -98,9 +90,13 @@ IN: factorbot-commands
         "Sorry, I couldn't find anything for " swap append respond
     ] [
         nip [
-            dup word-string " -- " rot word-url append3 respond
+            dup synopsis " -- http://factorcode.org"
+            rot browser-link-href append3 respond
         ] each
     ] if ;
 
 : quit ( text -- )
     drop speaker get "slava" = [ disconnect ] when ;
+
+: memory ( text -- )
+    drop [ room. ] string-out multiline-respond ;

library/opengl/opengl-utils.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: opengl
-USING: alien errors kernel math namespaces opengl sdl sequences ;
+USING: alien errors io kernel math namespaces opengl sdl
+sequences ;
 
 : gl-color ( { r g b a } -- ) first4 glColor4d ; inline
 
@@ -36,7 +37,8 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
     >r 0 gl-flags r> with-screen ; inline
 
 : gl-error ( -- )
-    glGetError dup zero? [ drop ] [ gluErrorString throw ] if ;
+    glGetError dup zero?
+    [ drop ] [ "GL error: " write gluErrorString print ] if ;
 
 : with-gl-surface ( quot -- )
     #! Execute a quotation, locking the current surface if it

library/ui/events.factor

@@ -47,4 +47,6 @@ M: quit-event handle-event ( event -- )
 M: resize-event handle-event ( event -- )
     flush-fonts
     gl-resize
-    width get height get 0 3array world get set-gadget-dim ;
+    world get remove-notify
+    width get height get 0 3array world get set-gadget-dim
+    world get add-notify ;

library/ui/gadgets.factor

@@ -90,9 +90,14 @@ M: gadget children-on ( rect/point gadget -- list )
 
 : max-dim ( dims -- dim ) { 0 0 0 } [ vmax ] reduce ;
 
+: each-child ( gadget quot -- )
+    >r gadget-children r> each ; inline
+
+: each-child-with ( obj gadget quot -- )
+    >r gadget-children r> each-with ; inline
+
 : set-gadget-delegate ( delegate gadget -- )
-    dup pick gadget-children [ set-gadget-parent ] each-with
-    set-delegate ;
+    dup pick [ set-gadget-parent ] each-child-with set-delegate ;
 
 ! Pointer help protocol
 GENERIC: gadget-help

library/ui/hierarchy.factor

@@ -4,20 +4,36 @@ IN: gadgets
 USING: gadgets-layouts generic hashtables kernel lists math
 namespaces sequences vectors ;
 
-: remove-gadget ( gadget parent -- )
-    f pick set-gadget-parent
-    [ gadget-children delete ] keep
-    relayout ;
+GENERIC: add-notify* ( gadget -- )
+
+M: gadget add-notify* drop ;
+
+: add-notify ( gadget -- )
+    dup [ add-notify ] each-child add-notify* ;
+
+GENERIC: remove-notify* ( gadget -- )
+
+M: gadget remove-notify* drop ;
+
+: remove-notify ( gadget -- )
+    dup [ remove-notify* ] each-child remove-notify* ;
+
+: (unparent) ( gadget -- )
+    dup remove-notify
+    dup forget-pref-dim f swap set-gadget-parent ;
 
 : unparent ( gadget -- )
     [
-        dup forget-pref-dim
-        dup gadget-parent dup
-        [ 2dup remove-gadget ] when 2drop
+        dup gadget-parent dup [
+            over (unparent)
+            [ gadget-children delete ] keep relayout
+        ] [
+            2drop
+        ] if
     ] when* ;
 
 : (clear-gadget) ( gadget -- )
-    dup gadget-children [ f swap set-gadget-parent ] each
+    dup gadget-children [ (unparent) ] each
     f swap set-gadget-children ;
 
 : clear-gadget ( gadget -- )
@@ -26,7 +42,8 @@ namespaces sequences vectors ;
 : (add-gadget) ( gadget box -- )
     over unparent
     dup pick set-gadget-parent
-    [ gadget-children ?push ] keep set-gadget-children ;
+    [ gadget-children ?push ] 2keep swapd set-gadget-children
+    add-notify ;
 
 : add-gadget ( gadget parent -- )
     #! Add a gadget to a parent gadget.

library/ui/layouts.factor

@@ -59,7 +59,7 @@ M: gadget layout* drop ;
 
 DEFER: layout
 
-: layout-children ( gadget -- ) gadget-children [ layout ] each ;
+: layout-children ( gadget -- ) [ layout ] each-child ;
 
 : layout ( gadget -- )
     #! Position the children of the gadget inside the gadget.

library/ui/paragraphs.factor

@@ -46,7 +46,7 @@ SYMBOL: margin
 : do-wrap ( paragraph quot -- dim | quot: pos child -- )
     [
         swap dup init-wrap
-        gadget-children [ wrap-step ] each-with wrap-dim
+        [ wrap-step ] each-child-with wrap-dim
     ] with-scope ; inline
 
 M: paragraph pref-dim* ( paragraph -- dim )