--- /dev/null
+! 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 ;
! 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
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 -- )
: 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* ;
+ [
+ irc-stream get stream-readln
+ [ dup print flush parse-irc irc-loop ] when*
+ ] [
+ irc-stream get stream-close
+ ] cleanup ;
: factorbot
"irc.freenode.net" connect
"#concatenative" join
irc-loop ;
+: factorbot-loop [ factorbot ] try factorbot-loop ;
+
+: multiline-respond ( string -- )
+ <string-reader> lines [ respond ] each ;
+
IN: factorbot-commands
: see ( text -- )
"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 ;
! 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
>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
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 ;
: 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
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 -- )
: (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.
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.
: 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 )