--- /dev/null
+unportable
+bindings
}
check_X11_libraries() {
- check_library_exists GLU
check_library_exists GL
check_library_exists X11
check_library_exists pango-1.0
}
install_build_system_apt() {
- sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
+ sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev wget git-core git-doc rlwrap gcc make
check_ret sudo
}
! Server message handling
-GENERIC: forward-message ( irc-message -- )
-M: irc-message forward-message +server-chat+ chat-put ;
-M: to-one-chat forward-message dup chat> chat-put ;
-M: to-all-chats forward-message chats> chat-put ;
-M: to-many-chats forward-message dup sender>> participant-chats chat-put ;
+GENERIC: message-forwards ( irc-message -- seq )
+M: irc-message message-forwards drop +server-chat+ ;
+M: to-one-chat message-forwards chat> ;
+M: to-all-chats message-forwards drop chats> ;
+M: to-many-chats message-forwards sender>> participant-chats ;
GENERIC: process-message ( irc-message -- )
M: object process-message drop ;
: handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ;
: (handle-disconnect) ( -- )
- irc> in-messages>> irc-disconnected swap mailbox-put
+ irc-disconnected irc> in-messages>> mailbox-put
irc> reconnect-time>> sleep
(connect-irc)
(do-login) ;
! Processing loops
: in-multiplexer-loop ( -- ? )
- irc> in-messages>> mailbox-get
- [ process-message ] [ forward-message ] [ irc-end? not ] tri ;
+ irc> in-messages>> mailbox-get {
+ [ message-forwards ]
+ [ process-message ]
+ [ swap chat-put ]
+ [ irc-end? not ]
+ } cleave ;
: strings>privmsg ( name string -- privmsg )
" :" prepend append "PRIVMSG " prepend string>irc-message ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors irc.messages irc.messages.base kernel make ;
+EXCLUDE: sequences => join ;
+IN: irc.logbot.log-line
+
+: dot-or-parens ( string -- string )
+ [ "." ] [ " (" prepend ")." append ] if-empty ;
+
+GENERIC: >log-line ( object -- line )
+
+M: irc-message >log-line line>> ;
+
+M: privmsg >log-line
+ [ "<" % dup sender>> % "> " % text>> % ] "" make ;
+
+M: join >log-line
+ [ "* " % sender>> % " has joined the channel." % ] "" make ;
+
+M: part >log-line
+ [ "* " % dup sender>> % " has left the channel" %
+ comment>> dot-or-parens % ] "" make ;
+
+M: quit >log-line
+ [ "* " % dup sender>> % " has quit" %
+ comment>> dot-or-parens % ] "" make ;
+
+M: kick >log-line
+ [ "* " % dup sender>> % " has kicked " % dup user>> %
+ " from the channel" % comment>> dot-or-parens % ] "" make ;
+
+M: participant-mode >log-line
+ [ "* " % dup sender>> % " has set mode " % dup mode>> %
+ " to " % parameter>> % ] "" make ;
+
+M: nick >log-line
+ [ "* " % dup sender>> % " is now known as " % nickname>> % ] "" make ;
--- /dev/null
+IRC message formatting for logs
--- /dev/null
+! Copyright (C) 2009 Bruno Deferrari.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar calendar.format destructors fry io io.encodings.8-bit
+io.files io.pathnames irc.client irc.client.chats irc.messages
+irc.messages.base kernel make namespaces sequences threads
+irc.logbot.log-line ;
+IN: irc.logbot
+
+CONSTANT: bot-channel "#concatenative"
+CONSTANT: log-directory "/tmp/logs"
+
+SYMBOL: current-day
+SYMBOL: current-stream
+
+: bot-profile ( -- obj )
+ "irc.freenode.org" 6667 "flogger" f <irc-profile> ;
+
+: add-timestamp ( string timestamp -- string )
+ timestamp>hms "[" prepend "] " append prepend ;
+
+: timestamp-path ( timestamp -- path )
+ timestamp>ymd ".log" append log-directory prepend-path ;
+
+: timestamp>stream ( timestamp -- stream )
+ dup day-of-year current-day get = [
+ drop
+ ] [
+ current-stream get [ dispose ] when*
+ [ day-of-year current-day set ]
+ [ timestamp-path latin1 <file-writer> ] bi
+ current-stream set
+ ] if current-stream get ;
+
+: log-message ( string timestamp -- )
+ [ add-timestamp ] [ timestamp>stream ] bi
+ [ stream-print ] [ stream-flush ] bi ;
+
+GENERIC: handle-message ( msg -- )
+
+M: object handle-message drop ;
+M: irc-message handle-message [ >log-line ] [ timestamp>> ] bi log-message ;
+
+: bot-loop ( chat -- ) dup hear handle-message bot-loop ;
+
+: start-bot ( -- )
+ bot-profile <irc-client>
+ [ connect-irc ]
+ [
+ [ bot-channel <irc-channel-chat> ] dip
+ '[ _ [ _ attach-chat ] [ bot-loop ] bi ]
+ "LogBot" spawn drop
+ ] bi ;
+
+: logbot ( -- ) start-bot ;
+
+MAIN: logbot
--- /dev/null
+An IRC logging bot
{ command "NICK" }
{ parameters { } }
{ trailing "someuser2" }
- { sender "someuser" } } }
+ { sender "someuser" }
+ { nickname "someuser2" } } }
[ ":someuser!n=user@some.where NICK :someuser2"
string>irc-message f >>timestamp ] unit-test
! connection
IRC: pass "PASS" password ;
-IRC: nick "NICK" nickname ;
+IRC: nick "NICK" : nickname ;
IRC: user "USER" user mode _ : realname ;
IRC: oper "OPER" name password ;
IRC: mode "MODE" name mode parameter ;
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: combinators io io.files io.files.links io.directories
io.pathnames io.streams.string kernel math math.parser
continuations namespaces pack prettyprint sequences strings
system tools.hexdump io.encodings.binary summary accessors
-io.backend byte-arrays ;
+io.backend byte-arrays io.streams.byte-array splitting ;
IN: tar
CONSTANT: zero-checksum 256
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
linkname magic version uname gname devmajor devminor prefix ;
-ERROR: checksum-error ;
-SYMBOLS: base-dir filename ;
+ERROR: checksum-error ;
-: tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
+: trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
-: read-c-string* ( n -- str/f )
+: read-c-string ( n -- str/f )
read [ zero? ] trim-tail [ f ] when-empty ;
: read-tar-header ( -- obj )
\ tar-header new
- 100 read-c-string* >>name
- 8 read-c-string* tar-trim oct> >>mode
- 8 read-c-string* tar-trim oct> >>uid
- 8 read-c-string* tar-trim oct> >>gid
- 12 read-c-string* tar-trim oct> >>size
- 12 read-c-string* tar-trim oct> >>mtime
- 8 read-c-string* tar-trim oct> >>checksum
- read1 >>typeflag
- 100 read-c-string* >>linkname
- 6 read >>magic
- 2 read >>version
- 32 read-c-string* >>uname
- 32 read-c-string* >>gname
- 8 read tar-trim oct> >>devmajor
- 8 read tar-trim oct> >>devminor
- 155 read-c-string* >>prefix ;
-
-: header-checksum ( seq -- x )
- 148 cut-slice 8 tail-slice
- [ sum ] bi@ + 256 + ;
+ 100 read-c-string >>name
+ 8 read-c-string trim-string oct> >>mode
+ 8 read-c-string trim-string oct> >>uid
+ 8 read-c-string trim-string oct> >>gid
+ 12 read-c-string trim-string oct> >>size
+ 12 read-c-string trim-string oct> >>mtime
+ 8 read-c-string trim-string oct> >>checksum
+ read1 >>typeflag
+ 100 read-c-string >>linkname
+ 6 read >>magic
+ 2 read >>version
+ 32 read-c-string >>uname
+ 32 read-c-string >>gname
+ 8 read trim-string oct> >>devmajor
+ 8 read trim-string oct> >>devminor
+ 155 read-c-string >>prefix ;
+
+: checksum-header ( seq -- n )
+ 148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ;
: read-data-blocks ( tar-header -- )
dup size>> 0 > [
] if ;
: parse-tar-header ( seq -- obj )
- [ header-checksum ] keep over zero-checksum = [
+ [ checksum-header ] keep over zero-checksum = [
2drop
\ tar-header new
0 >>size
0 >>checksum
] [
- [ read-tar-header ] with-string-reader
+ binary [ read-tar-header ] with-byte-reader
[ checksum>> = [ checksum-error ] unless ] keep
] if ;
ERROR: unknown-typeflag ch ;
-M: unknown-typeflag summary ( obj -- str )
- ch>> 1string "Unknown typeflag: " prepend ;
-: tar-prepend-path ( path -- newpath )
- base-dir get prepend-path ;
+M: unknown-typeflag summary ( obj -- str )
+ ch>> [ "Unknown typeflag: " ] dip prefix ;
: read/write-blocks ( tar-header path -- )
binary [ read-data-blocks ] with-file-writer ;
+: prepend-current-directory ( path -- path' )
+ current-directory get prepend-path ;
+
! Normal file
: typeflag-0 ( header -- )
- dup name>> tar-prepend-path read/write-blocks ;
+ dup name>> dup "global_pax_header" = [
+ drop [ read-data-blocks ] with-string-writer drop
+ ] [
+ prepend-current-directory read/write-blocks
+ ] if ;
! Hard link
: typeflag-1 ( header -- ) unknown-typeflag ;
! Directory
: typeflag-5 ( header -- )
- name>> tar-prepend-path make-directories ;
+ name>> prepend-current-directory make-directories ;
! FIFO
: typeflag-6 ( header -- ) unknown-typeflag ;
drop ;
! <string-writer> [ read-data-blocks ] keep
! >string [ zero? ] trim-tail filename set
- ! filename get tar-prepend-path make-directories ;
+ ! filename get prepend-current-directory make-directories ;
! Multi volume continuation entry
: typeflag-M ( header -- ) unknown-typeflag ;
: typeflag-X ( header -- ) unknown-typeflag ;
: (parse-tar) ( -- )
- block-size read dup length 512 = [
+ block-size read dup length block-size = [
parse-tar-header
dup typeflag>>
{
drop
] if ;
-: parse-tar ( path -- )
- normalize-path dup parent-directory base-dir [
+: untar ( path -- )
+ normalize-path [ ] [ parent-directory ] bi [
binary [ (parse-tar) ] with-file-reader
- ] with-variable ;
+ ] with-directory ;
(declaration keyword "declaration words")
(ebnf-form constant "EBNF: ... ;EBNF form")
(parsing-word keyword "parsing words")
+ (postpone-body comment "postponed form")
(setter-word function-name "setter words (>>foo)")
(getter-word function-name "getter words (foo>>)")
(stack-effect comment "stack effect specifications")
(defun fuel-font-lock--syntactic-face (state)
(if (nth 3 state) 'factor-font-lock-string
(let ((c (char-after (nth 8 state))))
- (cond ((or (char-equal c ?\ )
- (char-equal c ?\n)
- (char-equal c ?E))
+ (cond ((memq c '(?\ ?\n ?E ?P))
(save-excursion
(goto-char (nth 8 state))
(beginning-of-line)
- (cond ((looking-at-p "USING: ")
+ (cond ((looking-at "E") 'factor-font-lock-ebnf-form)
+ ((looking-at "P") 'factor-font-lock-postpone-body)
+ ((looking-at-p "USING: ")
'factor-font-lock-vocabulary-name)
- ((looking-at-p "\\(TUPLE\\|SYMBOLS\\|VARS\\|SINGLETONS\\):")
+ ((looking-at-p
+ "\\(TUPLE\\|SYMBOLS\\|VARS\\|SINGLETONS\\):")
'factor-font-lock-symbol)
((looking-at-p "C-ENUM:\\( \\|\n\\)")
'factor-font-lock-constant)
- ((looking-at-p "E")
- 'factor-font-lock-ebnf-form)
(t 'default))))
((or (char-equal c ?U) (char-equal c ?C))
'factor-font-lock-parsing-word)
(,fuel-syntax--alien-function-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
(,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
- (,fuel-syntax--constructor-decl-regex (1 'factor-font-lock-word)
- (2 'factor-font-lock-type-name)
- (3 'factor-font-lock-invalid-syntax nil t))
+ (,fuel-syntax--constructor-decl-regex
+ (1 'factor-font-lock-word)
+ (2 'factor-font-lock-type-name)
+ (3 'factor-font-lock-invalid-syntax nil t))
(,fuel-syntax--typedef-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-type-name)
(3 'factor-font-lock-invalid-syntax nil t))
;; Strings and chars
("CHAR: \\(\"\\) [^\\\"]*?\\(\"\\)\\([^\\\"]\\|\\\\.\\)*?\\(\"\\)"
(1 "w") (2 "\"") (4 "\""))
- ("\\(CHAR:\\|POSTPONE:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w"))
+ ("\\(CHAR:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w"))
("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)"
(3 "\"") (5 "\""))
("\\_<\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" (1 "\"") (3 "\""))
("\\_<<\\(\"\\)\\_>" (1 "<b"))
("\\_<\\(\"\\)>\\_>" (1 ">b"))
+ ;; postpone
+ ("\\_<POSTPONE:\\( \\).*\\(\n\\)" (1 "<b") (2 ">b"))
;; Multiline constructs
("\\_<\\(E\\)BNF:\\( \\|\n\\)" (1 "<b"))
("\\_<;EBN\\(F\\)\\_>" (1 ">b"))
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: tools.deploy.config ;
+V{
+ { deploy-ui? t }
+ { deploy-io 1 }
+ { deploy-reflection 1 }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { deploy-name "Jamshred" }
+}
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ;
+IN: jamshred.game
+
+TUPLE: jamshred sounds tunnel players running quit ;
+
+: <jamshred> ( -- jamshred )
+ <sounds> <random-tunnel> "Player 1" pick <player>
+ 2dup swap play-in-tunnel 1array f f jamshred boa ;
+
+: jamshred-player ( jamshred -- player )
+ ! TODO: support more than one player
+ players>> first ;
+
+: jamshred-update ( jamshred -- )
+ dup running>> [
+ jamshred-player update-player
+ ] [ drop ] if ;
+
+: toggle-running ( jamshred -- )
+ dup running>> [
+ f >>running drop
+ ] [
+ [ jamshred-player moved ]
+ [ t >>running drop ] bi
+ ] if ;
+
+: mouse-moved ( x-radians y-radians jamshred -- )
+ jamshred-player -rot turn-player ;
+
+: units-per-full-roll ( -- n ) 50 ;
+
+: jamshred-roll ( jamshred n -- )
+ [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ;
+
+: mouse-scroll-x ( jamshred x -- ) jamshred-roll ;
+
+: mouse-scroll-y ( jamshred y -- )
+ neg swap jamshred-player change-player-speed ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types jamshred.game jamshred.oint
+jamshred.player jamshred.tunnel kernel math math.constants
+math.functions math.vectors opengl opengl.gl opengl.glu
+opengl.demo-support sequences specialized-arrays.float ;
+IN: jamshred.gl
+
+: min-vertices 6 ; inline
+: max-vertices 32 ; inline
+
+: n-vertices ( -- n ) 32 ; inline
+
+! render enough of the tunnel that it looks continuous
+: n-segments-ahead ( -- n ) 60 ; inline
+: n-segments-behind ( -- n ) 40 ; inline
+
+: wall-drawing-offset ( -- n )
+ #! so that we can't see through the wall, we draw it a bit further away
+ 0.15 ;
+
+: wall-drawing-radius ( segment -- r )
+ radius>> wall-drawing-offset + ;
+
+: wall-up ( segment -- v )
+ [ wall-drawing-radius ] [ up>> ] bi n*v ;
+
+: wall-left ( segment -- v )
+ [ wall-drawing-radius ] [ left>> ] bi n*v ;
+
+: segment-vertex ( theta segment -- vertex )
+ [
+ [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+
+ ] [
+ location>> v+
+ ] bi ;
+
+: segment-vertex-normal ( vertex segment -- normal )
+ location>> swap v- normalize ;
+
+: segment-vertex-and-normal ( segment theta -- vertex normal )
+ swap [ segment-vertex ] keep dupd segment-vertex-normal ;
+
+: equally-spaced-radians ( n -- seq )
+ #! return a sequence of n numbers between 0 and 2pi
+ dup [ / pi 2 * * ] curry map ;
+
+: draw-segment-vertex ( segment theta -- )
+ over color>> gl-color segment-vertex-and-normal
+ gl-normal gl-vertex ;
+
+: draw-vertex-pair ( theta next-segment segment -- )
+ rot tuck draw-segment-vertex draw-segment-vertex ;
+
+: draw-segment ( next-segment segment -- )
+ GL_QUAD_STRIP [
+ [ draw-vertex-pair ] 2curry
+ n-vertices equally-spaced-radians F{ 0.0 } append swap each
+ ] do-state ;
+
+: draw-segments ( segments -- )
+ 1 over length pick subseq swap [ draw-segment ] 2each ;
+
+: segments-to-render ( player -- segments )
+ dup nearest-segment>> number>> dup n-segments-behind -
+ swap n-segments-ahead + rot tunnel>> sub-tunnel ;
+
+: draw-tunnel ( player -- )
+ segments-to-render draw-segments ;
+
+: init-graphics ( width height -- )
+ GL_DEPTH_TEST glEnable
+ GL_SCISSOR_TEST glDisable
+ 1.0 glClearDepth
+ 0.0 0.0 0.0 0.0 glClearColor
+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+ GL_PROJECTION glMatrixMode glLoadIdentity
+ dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if
+ GL_MODELVIEW glMatrixMode glLoadIdentity
+ GL_LEQUAL glDepthFunc
+ GL_LIGHTING glEnable
+ GL_LIGHT0 glEnable
+ GL_FOG glEnable
+ GL_FOG_DENSITY 0.09 glFogf
+ GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
+ GL_COLOR_MATERIAL glEnable
+ GL_LIGHT0 GL_POSITION float-array{ 0.0 0.0 0.0 1.0 } underlying>> glLightfv
+ GL_LIGHT0 GL_AMBIENT float-array{ 0.2 0.2 0.2 1.0 } underlying>> glLightfv
+ GL_LIGHT0 GL_DIFFUSE float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv
+ GL_LIGHT0 GL_SPECULAR float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv ;
+
+: player-view ( player -- )
+ [ location>> ]
+ [ [ location>> ] [ forward>> ] bi v+ ]
+ [ up>> ] tri gl-look-at ;
+
+: draw-jamshred ( jamshred width height -- )
+ init-graphics jamshred-player [ player-view ] [ draw-tunnel ] bi ;
+
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.geometry.rect math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ;
+IN: jamshred
+
+TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ;
+
+: <jamshred-gadget> ( jamshred -- gadget )
+ jamshred-gadget new-gadget swap >>jamshred ;
+
+: default-width ( -- x ) 800 ;
+: default-height ( -- y ) 600 ;
+
+M: jamshred-gadget pref-dim*
+ drop default-width default-height 2array ;
+
+M: jamshred-gadget draw-gadget* ( gadget -- )
+ [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ;
+
+: jamshred-loop ( gadget -- )
+ dup jamshred>> quit>> [
+ drop
+ ] [
+ [ jamshred>> jamshred-update ]
+ [ relayout-1 ]
+ [ 10 milliseconds sleep yield jamshred-loop ] tri
+ ] if ;
+
+: fullscreen ( gadget -- )
+ find-world t swap set-fullscreen* ;
+
+: no-fullscreen ( gadget -- )
+ find-world f swap set-fullscreen* ;
+
+: toggle-fullscreen ( world -- )
+ [ fullscreen? not ] keep set-fullscreen* ;
+
+M: jamshred-gadget graft* ( gadget -- )
+ [ jamshred-loop ] curry in-thread ;
+
+M: jamshred-gadget ungraft* ( gadget -- )
+ jamshred>> t swap (>>quit) ;
+
+: jamshred-restart ( jamshred-gadget -- )
+ <jamshred> >>jamshred drop ;
+
+: pix>radians ( n m -- theta )
+ / pi 4 * * ; ! 2 / / pi 2 * * ;
+
+: x>radians ( x gadget -- theta )
+ #! translate motion of x pixels to an angle
+ rect-dim first pix>radians neg ;
+
+: y>radians ( y gadget -- theta )
+ #! translate motion of y pixels to an angle
+ rect-dim second pix>radians ;
+
+: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
+ over jamshred>> >r
+ [ first swap x>radians ] 2keep second swap y>radians
+ r> mouse-moved ;
+
+: handle-mouse-motion ( jamshred-gadget -- )
+ hand-loc get [
+ over last-hand-loc>> [
+ v- (handle-mouse-motion)
+ ] [ 2drop ] if*
+ ] 2keep >>last-hand-loc drop ;
+
+: handle-mouse-scroll ( jamshred-gadget -- )
+ jamshred>> scroll-direction get
+ [ first mouse-scroll-x ]
+ [ second mouse-scroll-y ] 2bi ;
+
+: quit ( gadget -- )
+ [ no-fullscreen ] [ close-window ] bi ;
+
+jamshred-gadget H{
+ { T{ key-down f f "r" } [ jamshred-restart ] }
+ { T{ key-down f f " " } [ jamshred>> toggle-running ] }
+ { T{ key-down f f "f" } [ find-world toggle-fullscreen ] }
+ { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] }
+ { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] }
+ { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] }
+ { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] }
+ { T{ key-down f f "q" } [ quit ] }
+ { T{ motion } [ handle-mouse-motion ] }
+ { T{ mouse-scroll } [ handle-mouse-scroll ] }
+} set-gestures
+
+: jamshred-window ( -- gadget )
+ [ <jamshred> <jamshred-gadget> dup "Jamshred" open-window ] with-ui ;
+
+MAIN: jamshred-window
--- /dev/null
+USING: kernel logging ;
+IN: jamshred.log
+
+LOG: (jamshred-log) DEBUG
+
+: with-jamshred-log ( quot -- )
+ "jamshred" swap with-logging ;
+
+: jamshred-log ( message -- )
+ [ (jamshred-log) ] with-jamshred-log ; ! ugly...
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: jamshred.oint tools.test ;
+IN: jamshred.oint-tests
+
+[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
+[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test
+[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test
+[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test
+[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
+IN: jamshred.oint
+
+! An oint is a point with three linearly independent unit vectors
+! given relative to that point. In jamshred a player's location and
+! direction are given by the player's oint. Similarly, a tunnel
+! segment's location and orientation are given by an oint.
+
+TUPLE: oint location forward up left ;
+C: <oint> oint
+
+: rotation-quaternion ( theta axis -- quaternion )
+ swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ;
+
+: rotate-vector ( q qrecip v -- v )
+ v>q swap q* q* q>v ;
+
+: rotate-oint ( oint theta axis -- )
+ rotation-quaternion dup qrecip pick
+ [ forward>> rotate-vector >>forward ]
+ [ up>> rotate-vector >>up ]
+ [ left>> rotate-vector >>left ] 3tri drop ;
+
+: left-pivot ( oint theta -- )
+ over left>> rotate-oint ;
+
+: up-pivot ( oint theta -- )
+ over up>> rotate-oint ;
+
+: forward-pivot ( oint theta -- )
+ over forward>> rotate-oint ;
+
+: random-float+- ( n -- m )
+ #! find a random float between -n/2 and n/2
+ dup 10000 * >fixnum random 10000 / swap 2 / - ;
+
+: random-turn ( oint theta -- )
+ 2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
+
+: location+ ( v oint -- )
+ [ location>> v+ ] [ (>>location) ] bi ;
+
+: go-forward ( distance oint -- )
+ [ forward>> n*v ] [ location+ ] bi ;
+
+: distance-vector ( oint oint -- vector )
+ [ location>> ] bi@ swap v- ;
+
+: distance ( oint oint -- distance )
+ distance-vector norm ;
+
+: scalar-projection ( v1 v2 -- n )
+ #! the scalar projection of v1 onto v2
+ tuck v. swap norm / ;
+
+: proj-perp ( u v -- w )
+ dupd proj v- ;
+
+: perpendicular-distance ( oint oint -- distance )
+ tuck distance-vector swap 2dup left>> scalar-projection abs
+ -rot up>> scalar-projection abs + ;
+
+:: reflect ( v n -- v' )
+ #! bounce v on a surface with normal n
+ v v n v. n n v. / 2 * n n*v v- ;
+
+: half-way ( p1 p2 -- p3 )
+ over v- 2 v/n v+ ;
+
+: half-way-between-oints ( o1 o2 -- p )
+ [ location>> ] bi@ half-way ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors colors combinators float-arrays jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle strings system ;
+IN: jamshred.player
+
+TUPLE: player < oint
+ { name string }
+ { sounds sounds }
+ tunnel
+ nearest-segment
+ { last-move integer }
+ { speed float } ;
+
+! speeds are in GL units / second
+: default-speed ( -- speed ) 1.0 ;
+: max-speed ( -- speed ) 30.0 ;
+
+: <player> ( name sounds -- player )
+ [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip
+ f f 0 default-speed player boa ;
+
+: turn-player ( player x-radians y-radians -- )
+ >r over r> left-pivot up-pivot ;
+
+: roll-player ( player z-radians -- )
+ forward-pivot ;
+
+: to-tunnel-start ( player -- )
+ [ tunnel>> first dup location>> ]
+ [ tuck (>>location) (>>nearest-segment) ] bi ;
+
+: play-in-tunnel ( player segments -- )
+ >>tunnel to-tunnel-start ;
+
+: update-nearest-segment ( player -- )
+ [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
+ [ (>>nearest-segment) ] tri ;
+
+: update-time ( player -- seconds-passed )
+ millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
+
+: moved ( player -- ) millis swap (>>last-move) ;
+
+: speed-range ( -- range )
+ max-speed [0,b] ;
+
+: change-player-speed ( inc player -- )
+ [ + speed-range clamp-to-range ] change-speed drop ;
+
+: multiply-player-speed ( n player -- )
+ [ * speed-range clamp-to-range ] change-speed drop ;
+
+: distance-to-move ( seconds-passed player -- distance )
+ speed>> * ;
+
+: bounce ( d-left player -- d-left' player )
+ {
+ [ dup nearest-segment>> bounce-off-wall ]
+ [ sounds>> bang ]
+ [ 3/4 swap multiply-player-speed ]
+ [ ]
+ } cleave ;
+
+:: (distance) ( heading player -- current next location heading )
+ player nearest-segment>>
+ player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
+ player location>> heading ;
+
+: distance-to-heading-segment ( heading player -- distance )
+ (distance) distance-to-next-segment ;
+
+: distance-to-heading-segment-area ( heading player -- distance )
+ (distance) distance-to-next-segment-area ;
+
+: distance-to-collision ( player -- distance )
+ dup nearest-segment>> (distance-to-collision) ;
+
+: almost-to-collision ( player -- distance )
+ distance-to-collision 0.1 - dup 0 < [ drop 0 ] when ;
+
+: from ( player -- radius distance-from-centre )
+ [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
+ distance-from-centre ;
+
+: distance-from-wall ( player -- distance ) from - ;
+: fraction-from-centre ( player -- fraction ) from swap / ;
+: fraction-from-wall ( player -- fraction )
+ fraction-from-centre 1 swap - ;
+
+: update-nearest-segment2 ( heading player -- )
+ 2dup distance-to-heading-segment-area 0 <= [
+ [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
+ [ (>>nearest-segment) ] tri
+ ] [
+ 2drop
+ ] if ;
+
+:: move-player-on-heading ( d-left player distance heading -- d-left' player )
+ [let* | d-to-move [ d-left distance min ]
+ move-v [ d-to-move heading n*v ] |
+ move-v player location+
+ heading player update-nearest-segment2
+ d-left d-to-move - player ] ;
+
+: distance-to-move-freely ( player -- distance )
+ [ almost-to-collision ]
+ [ [ forward>> ] keep distance-to-heading-segment-area ] bi min ;
+
+: ?move-player-freely ( d-left player -- d-left' player )
+ over 0 > [
+ ! must make sure we are moving a significant distance, otherwise
+ ! we can recurse endlessly due to floating-point imprecision.
+ ! (at least I /think/ that's what causes it...)
+ dup distance-to-move-freely dup 0.1 > [
+ over forward>> move-player-on-heading ?move-player-freely
+ ] [ drop ] if
+ ] when ;
+
+: drag-heading ( player -- heading )
+ [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
+
+: drag-player ( d-left player -- d-left' player )
+ dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
+ [ drag-heading move-player-on-heading ] bi ;
+
+: (move-player) ( d-left player -- d-left' player )
+ ?move-player-freely over 0 > [
+ ! bounce
+ drag-player
+ (move-player)
+ ] when ;
+
+: move-player ( player -- )
+ [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
+
+: update-player ( player -- )
+ [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ;
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors io.files kernel openal sequences ;
+IN: jamshred.sound
+
+TUPLE: sounds bang ;
+
+: assign-sound ( source wav-path -- )
+ resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ;
+
+: <sounds> ( -- sounds )
+ init-openal 1 gen-sources first sounds boa
+ dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ;
+
+: bang ( sounds -- ) bang>> source-play check-error ;
--- /dev/null
+A simple 3d tunnel racing game
--- /dev/null
+applications
+games
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays float-arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences tools.test ;
+IN: jamshred.tunnel.tests
+
+[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
+ T{ segment f { 1 1 1 } f f f 1 }
+ T{ oint f { 0 0 0.25 } }
+ nearer-segment number>> ] unit-test
+
+[ 0 ] [ T{ oint f { 0 0 0 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
+[ 1 ] [ T{ oint f { 0 0 -1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
+[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
+
+[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward number>> ] unit-test
+
+[ F{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment location>> ] unit-test
+
+: test-segment-oint ( -- oint )
+ { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;
+
+[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test
+[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test
+[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test
+[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test
+[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test
+[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test
+[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test
+[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test
+
+: simplest-straight-ahead ( -- oint segment )
+ { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint>
+ initial-segment ;
+
+[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
+[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
+
+: simple-collision-up ( -- oint segment )
+ { 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } <oint>
+ initial-segment ;
+
+[ { 0.0 1.0 0.0 } ] [ simple-collision-up sideways-heading ] unit-test
+[ { 0.0 0.0 0.0 } ] [ simple-collision-up sideways-relative-location ] unit-test
+[ { 0.0 1.0 0.0 } ]
+[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays colors combinators float-arrays kernel
+locals math math.constants math.matrices math.order math.ranges
+math.vectors math.quadratic random sequences vectors jamshred.oint ;
+IN: jamshred.tunnel
+
+: n-segments ( -- n ) 5000 ; inline
+
+TUPLE: segment < oint number color radius ;
+C: <segment> segment
+
+: segment-number++ ( segment -- )
+ [ number>> 1+ ] keep (>>number) ;
+
+: random-color ( -- color )
+ { 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
+
+: tunnel-segment-distance ( -- n ) 0.4 ;
+: random-rotation-angle ( -- theta ) pi 20 / ;
+
+: random-segment ( previous-segment -- segment )
+ clone dup random-rotation-angle random-turn
+ tunnel-segment-distance over go-forward
+ random-color >>color dup segment-number++ ;
+
+: (random-segments) ( segments n -- segments )
+ dup 0 > [
+ >r dup peek random-segment over push r> 1- (random-segments)
+ ] [ drop ] if ;
+
+: default-segment-radius ( -- r ) 1 ;
+
+: initial-segment ( -- segment )
+ F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
+ 0 random-color default-segment-radius <segment> ;
+
+: random-segments ( n -- segments )
+ initial-segment 1vector swap (random-segments) ;
+
+: simple-segment ( n -- segment )
+ [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
+ random-color default-segment-radius <segment> ;
+
+: simple-segments ( n -- segments )
+ [ simple-segment ] map ;
+
+: <random-tunnel> ( -- segments )
+ n-segments random-segments ;
+
+: <straight-tunnel> ( -- segments )
+ n-segments simple-segments ;
+
+: sub-tunnel ( from to segments -- segments )
+ #! return segments between from and to, after clamping from and to to
+ #! valid values
+ [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
+
+: nearer-segment ( segment segment oint -- segment )
+ #! return whichever of the two segments is nearer to the oint
+ >r 2dup r> tuck distance >r distance r> < -rot ? ;
+
+: (find-nearest-segment) ( nearest next oint -- nearest ? )
+ #! find the nearest of 'next' and 'nearest' to 'oint', and return
+ #! t if the nearest hasn't changed
+ pick >r nearer-segment dup r> = ;
+
+: find-nearest-segment ( oint segments -- segment )
+ dup first swap rest-slice rot [ (find-nearest-segment) ] curry
+ find 2drop ;
+
+: nearest-segment-forward ( segments oint start -- segment )
+ rot dup length swap <slice> find-nearest-segment ;
+
+: nearest-segment-backward ( segments oint start -- segment )
+ swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
+
+: nearest-segment ( segments oint start-segment -- segment )
+ #! find the segment nearest to 'oint', and return it.
+ #! start looking at segment 'start-segment'
+ number>> over >r
+ [ nearest-segment-forward ] 3keep
+ nearest-segment-backward r> nearer-segment ;
+
+: get-segment ( segments n -- segment )
+ over sequence-index-range clamp-to-range swap nth ;
+
+: next-segment ( segments current-segment -- segment )
+ number>> 1+ get-segment ;
+
+: previous-segment ( segments current-segment -- segment )
+ number>> 1- get-segment ;
+
+: heading-segment ( segments current-segment heading -- segment )
+ #! the next segment on the given heading
+ over forward>> v. 0 <=> {
+ { +gt+ [ next-segment ] }
+ { +lt+ [ previous-segment ] }
+ { +eq+ [ nip ] } ! current segment
+ } case ;
+
+:: distance-to-next-segment ( current next location heading -- distance )
+ [let | cf [ current forward>> ] |
+ cf next location>> v. cf location v. - cf heading v. / ] ;
+
+:: distance-to-next-segment-area ( current next location heading -- distance )
+ [let | cf [ current forward>> ]
+ h [ next current half-way-between-oints ] |
+ cf h v. cf location v. - cf heading v. / ] ;
+
+: vector-to-centre ( seg loc -- v )
+ over location>> swap v- swap forward>> proj-perp ;
+
+: distance-from-centre ( seg loc -- distance )
+ vector-to-centre norm ;
+
+: wall-normal ( seg oint -- n )
+ location>> vector-to-centre normalize ;
+
+: distant ( -- n ) 1000 ;
+
+: max-real ( a b -- c )
+ #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
+ dup real? [
+ over real? [ max ] [ nip ] if
+ ] [
+ drop dup real? [ drop distant ] unless
+ ] if ;
+
+:: collision-coefficient ( v w r -- c )
+ v norm 0 = [
+ distant
+ ] [
+ [let* | a [ v dup v. ]
+ b [ v w v. 2 * ]
+ c [ w dup v. r sq - ] |
+ c b a quadratic max-real ]
+ ] if ;
+
+: sideways-heading ( oint segment -- v )
+ [ forward>> ] bi@ proj-perp ;
+
+: sideways-relative-location ( oint segment -- loc )
+ [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
+
+: (distance-to-collision) ( oint segment -- distance )
+ [ sideways-heading ] [ sideways-relative-location ]
+ [ nip radius>> ] 2tri collision-coefficient ;
+
+: collision-vector ( oint segment -- v )
+ dupd (distance-to-collision) swap forward>> n*v ;
+
+: bounce-forward ( segment oint -- )
+ [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
+
+: bounce-left ( segment oint -- )
+ #! must be done after forward
+ [ forward>> vneg ] dip [ left>> swap reflect ]
+ [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
+
+: bounce-up ( segment oint -- )
+ #! must be done after forward and left!
+ nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
+
+: bounce-off-wall ( oint segment -- )
+ swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
+
projects / factor.git / commitdiff