{ $notes "Useful for meta-programming with " { $link define-declared } "." }
{ $examples
{ $code
- "SYMBOL: my-dynamic-word"
+ "<< SYMBOL: my-dynamic-word"
"USING: math random words ;"
- "3 { [ + ] [ - ] [ * ] [ / ] } random curry"
- "(( x -- y )) define-declared"
+ "my-dynamic-word 3 { [ + ] [ - ] [ * ] [ / ] } random curry"
+ "(( x -- y )) define-declared >>"
}
} ;
{ $syntax "execute( stack -- effect )" }
{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ;
-{ POSTPONE: call( POSTPONE: execute( } related-words
\ No newline at end of file
+{ POSTPONE: call( POSTPONE: execute( } related-words
: mouse-moved ( x-radians y-radians jamshred -- )
jamshred-player -rot turn-player ;
-: units-per-full-roll ( -- n ) 50 ;
+CONSTANT: units-per-full-roll 50
: jamshred-roll ( jamshred n -- )
[ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ;
opengl.demo-support sequences specialized-arrays.float ;
IN: jamshred.gl
-: min-vertices ( -- n ) 6 ; inline
-: max-vertices ( -- n ) 32 ; inline
+CONSTANT: min-vertices 6
+CONSTANT: max-vertices 32
-: n-vertices ( -- n ) 32 ; inline
+CONSTANT: n-vertices 32
! render enough of the tunnel that it looks continuous
-: n-segments-ahead ( -- n ) 60 ; inline
-: n-segments-behind ( -- n ) 40 ; inline
+CONSTANT: n-segments-ahead 60
+CONSTANT: n-segments-behind 40
-: wall-drawing-offset ( -- n )
- #! so that we can't see through the wall, we draw it a bit further away
- 0.15 ;
+! so that we can't see through the wall, we draw it a bit further away
+CONSTANT: wall-drawing-offset 0.15
: wall-drawing-radius ( segment -- r )
radius>> wall-drawing-offset + ;
: <jamshred-gadget> ( jamshred -- gadget )
jamshred-gadget new swap >>jamshred ;
-: default-width ( -- x ) 800 ;
-: default-height ( -- y ) 600 ;
+CONSTANT: default-width 800
+CONSTANT: default-height 600
M: jamshred-gadget pref-dim*
drop default-width default-height 2array ;
{ speed float } ;
! speeds are in GL units / second
-: default-speed ( -- speed ) 1.0 ;
-: max-speed ( -- speed ) 30.0 ;
+CONSTANT: default-speed 1.0
+CONSTANT: max-speed 30.0
: <player> ( name sounds -- player )
[ float-array{ 0 0 5 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] 2dip
USING: accessors arrays colors combinators kernel locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences specialized-arrays.float vectors jamshred.oint ;
IN: jamshred.tunnel
-: n-segments ( -- n ) 5000 ; inline
+CONSTANT: n-segments 5000
TUPLE: segment < oint number color radius ;
C: <segment> segment
: 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 / ;
+CONSTANT: tunnel-segment-distance 0.4
+USE: words.constant
+DEFER: random-rotation-angle
+\ random-rotation-angle pi 20 / define-constant
: random-segment ( previous-segment -- segment )
clone dup random-rotation-angle random-turn
[ dup peek random-segment over push ] dip 1- (random-segments)
] [ drop ] if ;
-: default-segment-radius ( -- r ) 1 ;
+CONSTANT: default-segment-radius 1
: initial-segment ( -- segment )
float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 }
: wall-normal ( seg oint -- n )
location>> vector-to-centre normalize ;
-: distant ( -- n ) 1000 ;
+CONSTANT: distant 1000
: max-real ( a b -- c )
#! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
Alex Chapman
+Diego Martinelli
HELP: ch>morse
{ $values
{ "ch" "A character that has a morse code translation" } { "str" "A string consisting of zero or more dots and dashes" } }
-{ $description "If the given character has a morse code translation, then return that translation, otherwise return an empty string." } ;
+{ $description "If the given character has a morse code translation, then return that translation, otherwise return a ? character." } ;
HELP: morse>ch
{ $values
{ "str" "A string of dots and dashes that represents a single character in morse code" } { "ch" "The translated character" } }
-{ $description "If the given string represents a morse code character, then return that character, otherwise return f" } ;
+{ $description "If the given string represents a morse code character, then return that character, otherwise return a space character." } ;
HELP: >morse
{ $values
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: arrays morse strings tools.test ;
+IN: morse.tests
-[ "" ] [ CHAR: \\ ch>morse ] unit-test
+[ CHAR: ? ] [ CHAR: \\ ch>morse ] unit-test
[ "..." ] [ CHAR: s ch>morse ] unit-test
[ CHAR: s ] [ "..." morse>ch ] unit-test
-[ f ] [ "..--..--.." morse>ch ] unit-test
+[ CHAR: \s ] [ "..--..--.." morse>ch ] unit-test
[ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test
[ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test
[ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test
+[ ".- -... -.-." ] [ "abc" >morse ] unit-test
+
+[ "abc" ] [ ".- -... -.-." morse> ] unit-test
+
+[ "morse code" ] [
+ [MORSE
+ -- --- .-. ... . /
+ -.-. --- -.. .
+ MORSE] >morse morse> ] unit-test
+
+[ "morse code 123" ] [
+ [MORSE
+ __ ___ ._. ... . /
+ _._. ___ _.. . /
+ .____ ..___ ...__
+ MORSE] ] unit-test
+
+[ [MORSE
+ -- --- .-. ... . /
+ -.-. --- -.. .
+ MORSE] ] [
+ "morse code" >morse morse>
+] unit-test
+
+[ "factor rocks!" ] [
+ [MORSE
+ ..-. .- -.-. - --- .-. /
+ .-. --- -.-. -.- ... -.-.--
+ MORSE] ] unit-test
! [ ] [ "sos" 0.075 play-as-morse* ] unit-test
! [ ] [ "Factor rocks!" play-as-morse ] unit-test
-! Copyright (C) 2007, 2008 Alex Chapman
+! Copyright (C) 2007, 2008, 2009 Alex Chapman, 2009 Diego Martinelli
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors ascii assocs combinators hashtables kernel lists math
-namespaces make openal parser-combinators promises sequences
-strings synth synth.buffers unicode.case ;
+USING: accessors ascii assocs biassocs combinators hashtables kernel lists math
+namespaces make multiline openal parser sequences splitting strings synth synth.buffers ;
IN: morse
<PRIVATE
-: morse-codes ( -- array )
- {
- { CHAR: a ".-" }
- { CHAR: b "-..." }
- { CHAR: c "-.-." }
- { CHAR: d "-.." }
- { CHAR: e "." }
- { CHAR: f "..-." }
- { CHAR: g "--." }
- { CHAR: h "...." }
- { CHAR: i ".." }
- { CHAR: j ".---" }
- { CHAR: k "-.-" }
- { CHAR: l ".-.." }
- { CHAR: m "--" }
- { CHAR: n "-." }
- { CHAR: o "---" }
- { CHAR: p ".--." }
- { CHAR: q "--.-" }
- { CHAR: r ".-." }
- { CHAR: s "..." }
- { CHAR: t "-" }
- { CHAR: u "..-" }
- { CHAR: v "...-" }
- { CHAR: w ".--" }
- { CHAR: x "-..-" }
- { CHAR: y "-.--" }
- { CHAR: z "--.." }
- { CHAR: 1 ".----" }
- { CHAR: 2 "..---" }
- { CHAR: 3 "...--" }
- { CHAR: 4 "....-" }
- { CHAR: 5 "....." }
- { CHAR: 6 "-...." }
- { CHAR: 7 "--..." }
- { CHAR: 8 "---.." }
- { CHAR: 9 "----." }
- { CHAR: 0 "-----" }
- { CHAR: . ".-.-.-" }
- { CHAR: , "--..--" }
- { CHAR: ? "..--.." }
- { CHAR: ' ".----." }
- { CHAR: ! "-.-.--" }
- { CHAR: / "-..-." }
- { CHAR: ( "-.--." }
- { CHAR: ) "-.--.-" }
- { CHAR: & ".-..." }
- { CHAR: : "---..." }
- { CHAR: ; "-.-.-." }
- { CHAR: = "-...- " }
- { CHAR: + ".-.-." }
- { CHAR: - "-....-" }
- { CHAR: _ "..--.-" }
- { CHAR: " ".-..-." }
- { CHAR: $ "...-..-" }
- { CHAR: @ ".--.-." }
- { CHAR: \s "/" }
- } ;
-
-: ch>morse-assoc ( -- assoc )
- morse-codes >hashtable ;
-
-: morse>ch-assoc ( -- assoc )
- morse-codes [ reverse ] map >hashtable ;
+
+CONSTANT: dot-char CHAR: .
+CONSTANT: dash-char CHAR: -
+CONSTANT: char-gap-char CHAR: \s
+CONSTANT: word-gap-char CHAR: /
+CONSTANT: unknown-char CHAR: ?
PRIVATE>
-: ch>morse ( ch -- str )
- ch>lower ch>morse-assoc at* swap "" ? ;
+DEFER: morse-code-table
+
+H{
+ { CHAR: a ".-" }
+ { CHAR: b "-..." }
+ { CHAR: c "-.-." }
+ { CHAR: d "-.." }
+ { CHAR: e "." }
+ { CHAR: f "..-." }
+ { CHAR: g "--." }
+ { CHAR: h "...." }
+ { CHAR: i ".." }
+ { CHAR: j ".---" }
+ { CHAR: k "-.-" }
+ { CHAR: l ".-.." }
+ { CHAR: m "--" }
+ { CHAR: n "-." }
+ { CHAR: o "---" }
+ { CHAR: p ".--." }
+ { CHAR: q "--.-" }
+ { CHAR: r ".-." }
+ { CHAR: s "..." }
+ { CHAR: t "-" }
+ { CHAR: u "..-" }
+ { CHAR: v "...-" }
+ { CHAR: w ".--" }
+ { CHAR: x "-..-" }
+ { CHAR: y "-.--" }
+ { CHAR: z "--.." }
+ { CHAR: 1 ".----" }
+ { CHAR: 2 "..---" }
+ { CHAR: 3 "...--" }
+ { CHAR: 4 "....-" }
+ { CHAR: 5 "....." }
+ { CHAR: 6 "-...." }
+ { CHAR: 7 "--..." }
+ { CHAR: 8 "---.." }
+ { CHAR: 9 "----." }
+ { CHAR: 0 "-----" }
+ { CHAR: . ".-.-.-" }
+ { CHAR: , "--..--" }
+ { CHAR: ? "..--.." }
+ { CHAR: ' ".----." }
+ { CHAR: ! "-.-.--" }
+ { CHAR: / "-..-." }
+ { CHAR: ( "-.--." }
+ { CHAR: ) "-.--.-" }
+ { CHAR: & ".-..." }
+ { CHAR: : "---..." }
+ { CHAR: ; "-.-.-." }
+ { CHAR: = "-...- " }
+ { CHAR: + ".-.-." }
+ { CHAR: - "-....-" }
+ { CHAR: _ "..--.-" }
+ { CHAR: " ".-..-." }
+ { CHAR: $ "...-..-" }
+ { CHAR: @ ".--.-." }
+ { CHAR: \s "/" }
+} >biassoc \ morse-code-table set-global
+
+: morse-code-table ( -- biassoc )
+ \ morse-code-table get-global ;
+
+: ch>morse ( ch -- morse )
+ ch>lower morse-code-table at [ unknown-char ] unless* ;
: morse>ch ( str -- ch )
- morse>ch-assoc at* swap f ? ;
-
-: >morse ( str -- str )
- [
- [ CHAR: \s , ] [ ch>morse % ] interleave
- ] "" make ;
-
+ morse-code-table value-at [ char-gap-char ] unless* ;
+
<PRIVATE
+
+: word>morse ( str -- morse )
+ [ ch>morse ] { } map-as " " join ;
-: dot-char ( -- ch ) CHAR: . ;
-: dash-char ( -- ch ) CHAR: - ;
-: char-gap-char ( -- ch ) CHAR: \s ;
-: word-gap-char ( -- ch ) CHAR: / ;
-
-: =parser ( obj -- parser )
- [ = ] curry satisfy ;
+: sentence>morse ( str -- morse )
+ " " split [ word>morse ] map " / " join ;
+
+: trim-blanks ( str -- newstr )
+ [ blank? ] trim ; inline
-LAZY: 'dot' ( -- parser )
- dot-char =parser ;
+: morse>word ( morse -- str )
+ " " split [ morse>ch ] "" map-as ;
-LAZY: 'dash' ( -- parser )
- dash-char =parser ;
+: morse>sentence ( morse -- sentence )
+ "/" split [ trim-blanks morse>word ] map " " join ;
-LAZY: 'char-gap' ( -- parser )
- char-gap-char =parser ;
-
-LAZY: 'word-gap' ( -- parser )
- word-gap-char =parser ;
-
-LAZY: 'morse-char' ( -- parser )
- 'dot' 'dash' <|> <+> ;
-
-LAZY: 'morse-word' ( -- parser )
- 'morse-char' 'char-gap' list-of ;
-
-LAZY: 'morse-words' ( -- parser )
- 'morse-word' 'word-gap' list-of ;
+: replace-underscores ( str -- str' )
+ [ dup CHAR: _ = [ drop CHAR: - ] when ] map ;
PRIVATE>
-
-: morse> ( str -- str )
- 'morse-words' parse car parsed>> [
- [
- >string morse>ch
- ] map >string
- ] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ;
-
+
+: >morse ( str -- newstr )
+ trim-blanks sentence>morse ;
+
+: morse> ( morse -- plain )
+ replace-underscores morse>sentence ;
+
+SYNTAX: [MORSE "MORSE]" parse-multiline-string morse> parsed ;
+
<PRIVATE
+
SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
: queue ( symbol -- )
: intra-char-gap ( -- ) intra-char-gap-buffer queue ;
: letter-gap ( -- ) letter-gap-buffer queue ;
-: beep-freq ( -- n ) 880 ;
+CONSTANT: beep-freq 880
: <morse-buffer> ( -- buffer )
half-sample-freq <8bit-mono-buffer> ;
M: 16bit-stereo-buffer buffer-data
interleaved-stereo-data 16bit-buffer-data ;
-: telephone-sample-freq ( -- n ) 8000 ;
-: half-sample-freq ( -- n ) 22050 ;
-: cd-sample-freq ( -- n ) 44100 ;
-: digital-sample-freq ( -- n ) 48000 ;
-: professional-sample-freq ( -- n ) 88200 ;
+CONSTANT: telephone-sample-freq 8000
+CONSTANT: half-sample-freq 22050
+CONSTANT: cd-sample-freq 44100
+CONSTANT: digital-sample-freq 48000
+CONSTANT: professional-sample-freq 88200
: send-buffer ( buffer -- buffer )
{
projects / factor.git / commitdiff