Merge branch 'master' into experimental
Alex Chapman
commit
5ef623e239
|
|
@ -1 +1,2 @@
|
|||
unportable
|
||||
bindings
|
||||
|
|
|
|||
|
|
@ -0,0 +1,2 @@
|
|||
unportable
|
||||
bindings
|
||||
|
|
@ -139,7 +139,6 @@ check_library_exists() {
|
|||
}
|
||||
|
||||
check_X11_libraries() {
|
||||
check_library_exists GLU
|
||||
check_library_exists GL
|
||||
check_library_exists X11
|
||||
check_library_exists pango-1.0
|
||||
|
|
@ -491,7 +490,7 @@ make_boot_image() {
|
|||
}
|
||||
|
||||
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
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -45,11 +45,11 @@ M: sequence chat-put [ chat-put ] with each ;
|
|||
|
||||
! 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 ;
|
||||
|
|
@ -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-disconnect) ( -- )
|
||||
irc> in-messages>> irc-disconnected swap mailbox-put
|
||||
irc-disconnected irc> in-messages>> mailbox-put
|
||||
irc> reconnect-time>> sleep
|
||||
(connect-irc)
|
||||
(do-login) ;
|
||||
|
|
@ -113,8 +113,12 @@ M: f handle-input handle-disconnect ;
|
|||
! 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 ;
|
||||
|
|
|
|||
|
|
@ -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" }
|
||||
{ parameters { } }
|
||||
{ trailing "someuser2" }
|
||||
{ sender "someuser" } } }
|
||||
{ sender "someuser" }
|
||||
{ nickname "someuser2" } } }
|
||||
[ ":someuser!n=user@some.where NICK :someuser2"
|
||||
string>irc-message f >>timestamp ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: irc.messages
|
|||
|
||||
! 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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
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
|
||||
|
|
@ -10,37 +12,35 @@ CONSTANT: block-size 512
|
|||
|
||||
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 ;
|
||||
: 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-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 ;
|
||||
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 ;
|
||||
|
||||
: header-checksum ( seq -- x )
|
||||
148 cut-slice 8 tail-slice
|
||||
[ sum ] bi@ + 256 + ;
|
||||
: checksum-header ( seq -- n )
|
||||
148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ;
|
||||
|
||||
: read-data-blocks ( tar-header -- )
|
||||
dup size>> 0 > [
|
||||
|
|
@ -60,29 +60,34 @@ SYMBOLS: base-dir filename ;
|
|||
] 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 ;
|
||||
|
|
@ -99,7 +104,7 @@ M: unknown-typeflag summary ( obj -- str )
|
|||
|
||||
! Directory
|
||||
: typeflag-5 ( header -- )
|
||||
name>> tar-prepend-path make-directories ;
|
||||
name>> prepend-current-directory make-directories ;
|
||||
|
||||
! FIFO
|
||||
: typeflag-6 ( header -- ) unknown-typeflag ;
|
||||
|
|
@ -139,7 +144,7 @@ M: unknown-typeflag summary ( obj -- str )
|
|||
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 ;
|
||||
|
|
@ -157,7 +162,7 @@ M: unknown-typeflag summary ( obj -- str )
|
|||
: 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>>
|
||||
{
|
||||
|
|
@ -189,7 +194,7 @@ M: unknown-typeflag summary ( obj -- str )
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -60,6 +60,7 @@
|
|||
(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")
|
||||
|
|
@ -76,20 +77,19 @@
|
|||
(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)
|
||||
|
|
@ -102,9 +102,10 @@
|
|||
(,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))
|
||||
|
|
|
|||
|
|
@ -247,12 +247,14 @@
|
|||
;; 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"))
|
||||
|
|
|
|||
|
|
@ -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