Merge branch 'master' into experimental
Alex Chapman
commit
5ef623e239
|
|
@ -1 +1,2 @@
|
||||||
unportable
|
unportable
|
||||||
|
bindings
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
unportable
|
||||||
|
bindings
|
||||||
|
|
@ -139,7 +139,6 @@ check_library_exists() {
|
||||||
}
|
}
|
||||||
|
|
||||||
check_X11_libraries() {
|
check_X11_libraries() {
|
||||||
check_library_exists GLU
|
|
||||||
check_library_exists GL
|
check_library_exists GL
|
||||||
check_library_exists X11
|
check_library_exists X11
|
||||||
check_library_exists pango-1.0
|
check_library_exists pango-1.0
|
||||||
|
|
@ -491,7 +490,7 @@ make_boot_image() {
|
||||||
}
|
}
|
||||||
|
|
||||||
install_build_system_apt() {
|
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
|
check_ret sudo
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -45,11 +45,11 @@ M: sequence chat-put [ chat-put ] with each ;
|
||||||
|
|
||||||
! Server message handling
|
! Server message handling
|
||||||
|
|
||||||
GENERIC: forward-message ( irc-message -- )
|
GENERIC: message-forwards ( irc-message -- seq )
|
||||||
M: irc-message forward-message +server-chat+ chat-put ;
|
M: irc-message message-forwards drop +server-chat+ ;
|
||||||
M: to-one-chat forward-message dup chat> chat-put ;
|
M: to-one-chat message-forwards chat> ;
|
||||||
M: to-all-chats forward-message chats> chat-put ;
|
M: to-all-chats message-forwards drop chats> ;
|
||||||
M: to-many-chats forward-message dup sender>> participant-chats chat-put ;
|
M: to-many-chats message-forwards sender>> participant-chats ;
|
||||||
|
|
||||||
GENERIC: process-message ( irc-message -- )
|
GENERIC: process-message ( irc-message -- )
|
||||||
M: object process-message drop ;
|
M: object process-message drop ;
|
||||||
|
|
@ -91,7 +91,7 @@ M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
|
||||||
: handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ;
|
: handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ;
|
||||||
|
|
||||||
: (handle-disconnect) ( -- )
|
: (handle-disconnect) ( -- )
|
||||||
irc> in-messages>> irc-disconnected swap mailbox-put
|
irc-disconnected irc> in-messages>> mailbox-put
|
||||||
irc> reconnect-time>> sleep
|
irc> reconnect-time>> sleep
|
||||||
(connect-irc)
|
(connect-irc)
|
||||||
(do-login) ;
|
(do-login) ;
|
||||||
|
|
@ -113,8 +113,12 @@ M: f handle-input handle-disconnect ;
|
||||||
! Processing loops
|
! Processing loops
|
||||||
|
|
||||||
: in-multiplexer-loop ( -- ? )
|
: in-multiplexer-loop ( -- ? )
|
||||||
irc> in-messages>> mailbox-get
|
irc> in-messages>> mailbox-get {
|
||||||
[ process-message ] [ forward-message ] [ irc-end? not ] tri ;
|
[ message-forwards ]
|
||||||
|
[ process-message ]
|
||||||
|
[ swap chat-put ]
|
||||||
|
[ irc-end? not ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
: strings>privmsg ( name string -- privmsg )
|
: strings>privmsg ( name string -- privmsg )
|
||||||
" :" prepend append "PRIVMSG " prepend string>irc-message ;
|
" :" prepend append "PRIVMSG " prepend string>irc-message ;
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Bruno Deferrari
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Bruno Deferrari
|
||||||
|
|
@ -0,0 +1,37 @@
|
||||||
|
! 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 ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
IRC message formatting for logs
|
||||||
|
|
@ -0,0 +1,56 @@
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
An IRC logging bot
|
||||||
|
|
@ -58,7 +58,8 @@ IN: irc.messages.tests
|
||||||
{ command "NICK" }
|
{ command "NICK" }
|
||||||
{ parameters { } }
|
{ parameters { } }
|
||||||
{ trailing "someuser2" }
|
{ trailing "someuser2" }
|
||||||
{ sender "someuser" } } }
|
{ sender "someuser" }
|
||||||
|
{ nickname "someuser2" } } }
|
||||||
[ ":someuser!n=user@some.where NICK :someuser2"
|
[ ":someuser!n=user@some.where NICK :someuser2"
|
||||||
string>irc-message f >>timestamp ] unit-test
|
string>irc-message f >>timestamp ] unit-test
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -7,7 +7,7 @@ IN: irc.messages
|
||||||
|
|
||||||
! connection
|
! connection
|
||||||
IRC: pass "PASS" password ;
|
IRC: pass "PASS" password ;
|
||||||
IRC: nick "NICK" nickname ;
|
IRC: nick "NICK" : nickname ;
|
||||||
IRC: user "USER" user mode _ : realname ;
|
IRC: user "USER" user mode _ : realname ;
|
||||||
IRC: oper "OPER" name password ;
|
IRC: oper "OPER" name password ;
|
||||||
IRC: mode "MODE" name mode parameter ;
|
IRC: mode "MODE" name mode parameter ;
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,10 @@
|
||||||
|
! Copyright (C) 2009 Doug Coleman.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: combinators io io.files io.files.links io.directories
|
USING: combinators io io.files io.files.links io.directories
|
||||||
io.pathnames io.streams.string kernel math math.parser
|
io.pathnames io.streams.string kernel math math.parser
|
||||||
continuations namespaces pack prettyprint sequences strings
|
continuations namespaces pack prettyprint sequences strings
|
||||||
system tools.hexdump io.encodings.binary summary accessors
|
system tools.hexdump io.encodings.binary summary accessors
|
||||||
io.backend byte-arrays ;
|
io.backend byte-arrays io.streams.byte-array splitting ;
|
||||||
IN: tar
|
IN: tar
|
||||||
|
|
||||||
CONSTANT: zero-checksum 256
|
CONSTANT: zero-checksum 256
|
||||||
|
|
@ -10,37 +12,35 @@ CONSTANT: block-size 512
|
||||||
|
|
||||||
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
|
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
|
||||||
linkname magic version uname gname devmajor devminor prefix ;
|
linkname magic version uname gname devmajor devminor prefix ;
|
||||||
|
|
||||||
ERROR: checksum-error ;
|
ERROR: checksum-error ;
|
||||||
|
|
||||||
SYMBOLS: base-dir filename ;
|
: trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
|
||||||
|
|
||||||
: tar-trim ( 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 [ zero? ] trim-tail [ f ] when-empty ;
|
||||||
|
|
||||||
: read-tar-header ( -- obj )
|
: read-tar-header ( -- obj )
|
||||||
\ tar-header new
|
\ tar-header new
|
||||||
100 read-c-string* >>name
|
100 read-c-string >>name
|
||||||
8 read-c-string* tar-trim oct> >>mode
|
8 read-c-string trim-string oct> >>mode
|
||||||
8 read-c-string* tar-trim oct> >>uid
|
8 read-c-string trim-string oct> >>uid
|
||||||
8 read-c-string* tar-trim oct> >>gid
|
8 read-c-string trim-string oct> >>gid
|
||||||
12 read-c-string* tar-trim oct> >>size
|
12 read-c-string trim-string oct> >>size
|
||||||
12 read-c-string* tar-trim oct> >>mtime
|
12 read-c-string trim-string oct> >>mtime
|
||||||
8 read-c-string* tar-trim oct> >>checksum
|
8 read-c-string trim-string oct> >>checksum
|
||||||
read1 >>typeflag
|
read1 >>typeflag
|
||||||
100 read-c-string* >>linkname
|
100 read-c-string >>linkname
|
||||||
6 read >>magic
|
6 read >>magic
|
||||||
2 read >>version
|
2 read >>version
|
||||||
32 read-c-string* >>uname
|
32 read-c-string >>uname
|
||||||
32 read-c-string* >>gname
|
32 read-c-string >>gname
|
||||||
8 read tar-trim oct> >>devmajor
|
8 read trim-string oct> >>devmajor
|
||||||
8 read tar-trim oct> >>devminor
|
8 read trim-string oct> >>devminor
|
||||||
155 read-c-string* >>prefix ;
|
155 read-c-string >>prefix ;
|
||||||
|
|
||||||
: header-checksum ( seq -- x )
|
: checksum-header ( seq -- n )
|
||||||
148 cut-slice 8 tail-slice
|
148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ;
|
||||||
[ sum ] bi@ + 256 + ;
|
|
||||||
|
|
||||||
: read-data-blocks ( tar-header -- )
|
: read-data-blocks ( tar-header -- )
|
||||||
dup size>> 0 > [
|
dup size>> 0 > [
|
||||||
|
|
@ -60,29 +60,34 @@ SYMBOLS: base-dir filename ;
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: parse-tar-header ( seq -- obj )
|
: parse-tar-header ( seq -- obj )
|
||||||
[ header-checksum ] keep over zero-checksum = [
|
[ checksum-header ] keep over zero-checksum = [
|
||||||
2drop
|
2drop
|
||||||
\ tar-header new
|
\ tar-header new
|
||||||
0 >>size
|
0 >>size
|
||||||
0 >>checksum
|
0 >>checksum
|
||||||
] [
|
] [
|
||||||
[ read-tar-header ] with-string-reader
|
binary [ read-tar-header ] with-byte-reader
|
||||||
[ checksum>> = [ checksum-error ] unless ] keep
|
[ checksum>> = [ checksum-error ] unless ] keep
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
ERROR: unknown-typeflag ch ;
|
ERROR: unknown-typeflag ch ;
|
||||||
M: unknown-typeflag summary ( obj -- str )
|
|
||||||
ch>> 1string "Unknown typeflag: " prepend ;
|
|
||||||
|
|
||||||
: tar-prepend-path ( path -- newpath )
|
M: unknown-typeflag summary ( obj -- str )
|
||||||
base-dir get prepend-path ;
|
ch>> [ "Unknown typeflag: " ] dip prefix ;
|
||||||
|
|
||||||
: read/write-blocks ( tar-header path -- )
|
: read/write-blocks ( tar-header path -- )
|
||||||
binary [ read-data-blocks ] with-file-writer ;
|
binary [ read-data-blocks ] with-file-writer ;
|
||||||
|
|
||||||
|
: prepend-current-directory ( path -- path' )
|
||||||
|
current-directory get prepend-path ;
|
||||||
|
|
||||||
! Normal file
|
! Normal file
|
||||||
: typeflag-0 ( header -- )
|
: 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
|
! Hard link
|
||||||
: typeflag-1 ( header -- ) unknown-typeflag ;
|
: typeflag-1 ( header -- ) unknown-typeflag ;
|
||||||
|
|
@ -99,7 +104,7 @@ M: unknown-typeflag summary ( obj -- str )
|
||||||
|
|
||||||
! Directory
|
! Directory
|
||||||
: typeflag-5 ( header -- )
|
: typeflag-5 ( header -- )
|
||||||
name>> tar-prepend-path make-directories ;
|
name>> prepend-current-directory make-directories ;
|
||||||
|
|
||||||
! FIFO
|
! FIFO
|
||||||
: typeflag-6 ( header -- ) unknown-typeflag ;
|
: typeflag-6 ( header -- ) unknown-typeflag ;
|
||||||
|
|
@ -139,7 +144,7 @@ M: unknown-typeflag summary ( obj -- str )
|
||||||
drop ;
|
drop ;
|
||||||
! <string-writer> [ read-data-blocks ] keep
|
! <string-writer> [ read-data-blocks ] keep
|
||||||
! >string [ zero? ] trim-tail filename set
|
! >string [ zero? ] trim-tail filename set
|
||||||
! filename get tar-prepend-path make-directories ;
|
! filename get prepend-current-directory make-directories ;
|
||||||
|
|
||||||
! Multi volume continuation entry
|
! Multi volume continuation entry
|
||||||
: typeflag-M ( header -- ) unknown-typeflag ;
|
: typeflag-M ( header -- ) unknown-typeflag ;
|
||||||
|
|
@ -157,7 +162,7 @@ M: unknown-typeflag summary ( obj -- str )
|
||||||
: typeflag-X ( header -- ) unknown-typeflag ;
|
: typeflag-X ( header -- ) unknown-typeflag ;
|
||||||
|
|
||||||
: (parse-tar) ( -- )
|
: (parse-tar) ( -- )
|
||||||
block-size read dup length 512 = [
|
block-size read dup length block-size = [
|
||||||
parse-tar-header
|
parse-tar-header
|
||||||
dup typeflag>>
|
dup typeflag>>
|
||||||
{
|
{
|
||||||
|
|
@ -189,7 +194,7 @@ M: unknown-typeflag summary ( obj -- str )
|
||||||
drop
|
drop
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: parse-tar ( path -- )
|
: untar ( path -- )
|
||||||
normalize-path dup parent-directory base-dir [
|
normalize-path [ ] [ parent-directory ] bi [
|
||||||
binary [ (parse-tar) ] with-file-reader
|
binary [ (parse-tar) ] with-file-reader
|
||||||
] with-variable ;
|
] with-directory ;
|
||||||
|
|
|
||||||
|
|
@ -60,6 +60,7 @@
|
||||||
(declaration keyword "declaration words")
|
(declaration keyword "declaration words")
|
||||||
(ebnf-form constant "EBNF: ... ;EBNF form")
|
(ebnf-form constant "EBNF: ... ;EBNF form")
|
||||||
(parsing-word keyword "parsing words")
|
(parsing-word keyword "parsing words")
|
||||||
|
(postpone-body comment "postponed form")
|
||||||
(setter-word function-name "setter words (>>foo)")
|
(setter-word function-name "setter words (>>foo)")
|
||||||
(getter-word function-name "getter words (foo>>)")
|
(getter-word function-name "getter words (foo>>)")
|
||||||
(stack-effect comment "stack effect specifications")
|
(stack-effect comment "stack effect specifications")
|
||||||
|
|
@ -76,20 +77,19 @@
|
||||||
(defun fuel-font-lock--syntactic-face (state)
|
(defun fuel-font-lock--syntactic-face (state)
|
||||||
(if (nth 3 state) 'factor-font-lock-string
|
(if (nth 3 state) 'factor-font-lock-string
|
||||||
(let ((c (char-after (nth 8 state))))
|
(let ((c (char-after (nth 8 state))))
|
||||||
(cond ((or (char-equal c ?\ )
|
(cond ((memq c '(?\ ?\n ?E ?P))
|
||||||
(char-equal c ?\n)
|
|
||||||
(char-equal c ?E))
|
|
||||||
(save-excursion
|
(save-excursion
|
||||||
(goto-char (nth 8 state))
|
(goto-char (nth 8 state))
|
||||||
(beginning-of-line)
|
(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)
|
'factor-font-lock-vocabulary-name)
|
||||||
((looking-at-p "\\(TUPLE\\|SYMBOLS\\|VARS\\|SINGLETONS\\):")
|
((looking-at-p
|
||||||
|
"\\(TUPLE\\|SYMBOLS\\|VARS\\|SINGLETONS\\):")
|
||||||
'factor-font-lock-symbol)
|
'factor-font-lock-symbol)
|
||||||
((looking-at-p "C-ENUM:\\( \\|\n\\)")
|
((looking-at-p "C-ENUM:\\( \\|\n\\)")
|
||||||
'factor-font-lock-constant)
|
'factor-font-lock-constant)
|
||||||
((looking-at-p "E")
|
|
||||||
'factor-font-lock-ebnf-form)
|
|
||||||
(t 'default))))
|
(t 'default))))
|
||||||
((or (char-equal c ?U) (char-equal c ?C))
|
((or (char-equal c ?U) (char-equal c ?C))
|
||||||
'factor-font-lock-parsing-word)
|
'factor-font-lock-parsing-word)
|
||||||
|
|
@ -102,9 +102,10 @@
|
||||||
(,fuel-syntax--alien-function-regex (1 'factor-font-lock-type-name)
|
(,fuel-syntax--alien-function-regex (1 'factor-font-lock-type-name)
|
||||||
(2 'factor-font-lock-word))
|
(2 'factor-font-lock-word))
|
||||||
(,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
|
(,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
|
||||||
(,fuel-syntax--constructor-decl-regex (1 'factor-font-lock-word)
|
(,fuel-syntax--constructor-decl-regex
|
||||||
(2 'factor-font-lock-type-name)
|
(1 'factor-font-lock-word)
|
||||||
(3 'factor-font-lock-invalid-syntax nil t))
|
(2 'factor-font-lock-type-name)
|
||||||
|
(3 'factor-font-lock-invalid-syntax nil t))
|
||||||
(,fuel-syntax--typedef-regex (1 'factor-font-lock-type-name)
|
(,fuel-syntax--typedef-regex (1 'factor-font-lock-type-name)
|
||||||
(2 'factor-font-lock-type-name)
|
(2 'factor-font-lock-type-name)
|
||||||
(3 'factor-font-lock-invalid-syntax nil t))
|
(3 'factor-font-lock-invalid-syntax nil t))
|
||||||
|
|
|
||||||
|
|
@ -247,12 +247,14 @@
|
||||||
;; Strings and chars
|
;; Strings and chars
|
||||||
("CHAR: \\(\"\\) [^\\\"]*?\\(\"\\)\\([^\\\"]\\|\\\\.\\)*?\\(\"\\)"
|
("CHAR: \\(\"\\) [^\\\"]*?\\(\"\\)\\([^\\\"]\\|\\\\.\\)*?\\(\"\\)"
|
||||||
(1 "w") (2 "\"") (4 "\""))
|
(1 "w") (2 "\"") (4 "\""))
|
||||||
("\\(CHAR:\\|POSTPONE:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w"))
|
("\\(CHAR:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w"))
|
||||||
("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)"
|
("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)"
|
||||||
(3 "\"") (5 "\""))
|
(3 "\"") (5 "\""))
|
||||||
("\\_<\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" (1 "\"") (3 "\""))
|
("\\_<\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" (1 "\"") (3 "\""))
|
||||||
("\\_<<\\(\"\\)\\_>" (1 "<b"))
|
("\\_<<\\(\"\\)\\_>" (1 "<b"))
|
||||||
("\\_<\\(\"\\)>\\_>" (1 ">b"))
|
("\\_<\\(\"\\)>\\_>" (1 ">b"))
|
||||||
|
;; postpone
|
||||||
|
("\\_<POSTPONE:\\( \\).*\\(\n\\)" (1 "<b") (2 ">b"))
|
||||||
;; Multiline constructs
|
;; Multiline constructs
|
||||||
("\\_<\\(E\\)BNF:\\( \\|\n\\)" (1 "<b"))
|
("\\_<\\(E\\)BNF:\\( \\|\n\\)" (1 "<b"))
|
||||||
("\\_<;EBN\\(F\\)\\_>" (1 ">b"))
|
("\\_<;EBN\\(F\\)\\_>" (1 ">b"))
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Alex Chapman
|
||||||
|
|
@ -0,0 +1,12 @@
|
||||||
|
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" }
|
||||||
|
}
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Alex Chapman
|
||||||
|
|
@ -0,0 +1,40 @@
|
||||||
|
! 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 ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Alex Chapman
|
||||||
|
|
@ -0,0 +1,99 @@
|
||||||
|
! 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 ;
|
||||||
|
|
||||||
|
|
@ -0,0 +1,94 @@
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1,10 @@
|
||||||
|
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...
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Alex Chapman
|
||||||
|
|
@ -0,0 +1,8 @@
|
||||||
|
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
|
||||||
|
|
@ -0,0 +1,73 @@
|
||||||
|
! 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 ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Alex Chapman
|
||||||
|
|
@ -0,0 +1,137 @@
|
||||||
|
! 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 ;
|
||||||
|
|
@ -0,0 +1,15 @@
|
||||||
|
! 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 ;
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
A simple 3d tunnel racing game
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
applications
|
||||||
|
games
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Alex Chapman
|
||||||
|
|
@ -0,0 +1,45 @@
|
||||||
|
! 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
|
||||||
|
|
@ -0,0 +1,167 @@
|
||||||
|
! 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 ;
|
||||||
|
|
||||||
Loading…
Reference in New Issue