Overview
| SHA1 Hash: | 4aac9ffad0c0271062d15a2d83a66fe7f7cd147c |
|---|---|
| Date: | 2011-08-22 02:47:12 |
| User: | crc |
| Comment: | Start adding newer rosetta code examples |
| Timelines: | family | ancestors | descendants | both | trunk |
| Other Links: | files | manifest |
Tags And Properties
- branch=trunk inherited from [dc67bca1f3]
- sym-trunk inherited from [dc67bca1f3]
Changes
[hide diffs]
[patch]Added rosetta_code/apply_a_callback_to_an_array.rx version [708d071c00666a42]
@@ -0,0 +1,8 @@ +Using the array' library to multiply each value in an array by 10 and display the results: + + [ 1 2 3 4 5 ] ^array'fromQuote [ 10 * ] ^array'map ^array'display + +Retro also provides ^array'apply for use when you don't want to alter the contents of the array: + + [ "Hello" "World" "Foo" ] ^array'fromQuote [ "%s " puts ] ^array'apply +
Added rosetta_code/binary_digits.rx version [ba8877bcaedd01f2]
@@ -0,0 +1,2 @@ +9000 50 5 3 [ binary putn cr decimal ] times +
Added rosetta_code/conways_game_of_life.rx version [33e97e1e7afb54ea]
@@ -0,0 +1,78 @@
+create world
+ 20 20 * allot
+
+create next
+ 20 20 * allot
+
+create initial
+( 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 )
+( 0 ) 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
+( 1 ) 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 1 , 0 , 0 , 1 , 1 , 0 ,
+( 2 ) 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 1 , 0 , 0 , 1 , 1 , 0 ,
+( 3 ) 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 1 , 0 , 0 , 0 , 0 , 0 ,
+( 4 ) 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
+( 5 ) 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
+( 6 ) 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
+( 7 ) 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
+( 8 ) 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
+( 9 ) 0 , 0 , 0 , 0 , 0 , 0 , 1 , 0 , 1 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
+( 10 ) 0 , 0 , 0 , 0 , 0 , 0 , 1 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
+( 11 ) 0 , 0 , 0 , 0 , 0 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
+( 12 ) 0 , 0 , 0 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
+( 13 ) 0 , 0 , 1 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
+( 14 ) 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 1 , 1 , 0 , 0 , 0 , 0 ,
+( 15 ) 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 1 , 1 , 0 , 0 , 0 , 0 ,
+( 16 ) 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 1 , 1 , 0 , 0 ,
+( 17 ) 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 1 , 1 , 0 , 0 ,
+( 18 ) 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
+( 19 ) 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
+
+( Assumes anything outside the bounds is "dead" )
+{{
+ variable surrounding
+ : get ( rc- )
+ 2over [ 0 19 within ] bi@ and
+ [ world + [ 20 * ] dip + @ ] [ 2drop 0 ] if ;
+ : neighbor? ( rc- ) get +surrounding ;
+ : NW ( rc-rc ) 2over [ 1- ] bi@ neighbor? ;
+ : NN ( rc-rc ) 2over [ 1- ] dip neighbor? ;
+ : NE ( rc-rc ) 2over [ 1- ] dip 1+ neighbor? ;
+ : WW ( rc-rc ) 2over 1- neighbor? ;
+ : EE ( rc-rc ) 2over 1+ neighbor? ;
+ : SW ( rc-rc ) 2over [ 1+ ] dip 1- neighbor? ;
+ : SS ( rc-rc ) 2over [ 1+ ] dip neighbor? ;
+ : SE ( rc-rc ) 2over [ 1+ ] bi@ neighbor? ;
+ : count ( rc-rcn )
+ 0 !surrounding
+ NW NN NE
+ WW EE
+ SW SS SE @surrounding ;
+ : alive ( rc-n )
+ count
+ [ 0 1 within ] [ drop 0 ] when
+ [ 4 8 within ] [ drop 0 ] when
+ [ 2 3 within ] [ drop 1 ] when ;
+ : dead ( rc-n )
+ count
+ [ 3 = ] [ drop 1 ] when
+ [ 0 2 within ] [ drop 0 ] when
+ [ 4 8 within ] [ drop 0 ] when ;
+ : newState ( rc-n )
+ 2over get 1 = [ alive ] [ dead ] if ;
+ : set ( nrc- ) next + [ 20 * ] dip + ! ;
+ : cols ( r- )
+ 20 [ over swap newState 2rot set ] iter drop ;
+ : output ( n- ) [ 'o ] [ '. ] if putc space ;
+---reveal---
+ : display ( - )
+ cr world 20 [ 20 [ @+ output ] times cr ] times drop ;
+ : start ( - )
+ initial world 20 20 * copy display ;
+ : gen ( - )
+ 20 [ cols ] iter next world 20 20 * copy ;
+ : delay ( - ) time 1+ [ time over <= ] while drop ;
+ : run ( n- )
+ [ delay clear gen display ] times ;
+}}
+
+start 20 run
Added rosetta_code/counting_in_octal.rx version [94e92f7ee83a41d5]
@@ -0,0 +1,3 @@ +octal +17777777777 [ putn cr ] iter +
Added rosetta_code/create_an_html_table.rx version [cd20f7248f06ac56]
@@ -0,0 +1,16 @@ +Using the casket::html' library which allows creation of HTML using quotes and combinators: + + needs casket::html' + + with casket::html' + : rnd ( -$ ) random 1000 mod toString ; + + [ [ [ ] td [ "x" ] td [ "y" ] td [ "z" ] td ] tr + [ [ "1" ] td [ rnd ] td [ rnd ] td [ rnd ] td ] tr + [ [ "2" ] td [ rnd ] td [ rnd ] td [ rnd ] td ] tr + [ [ "3" ] td [ rnd ] td [ rnd ] td [ rnd ] td ] tr + [ [ "4" ] td [ rnd ] td [ rnd ] td [ rnd ] td ] tr + [ [ "5" ] td [ rnd ] td [ rnd ] td [ rnd ] td ] tr + [ [ "6" ] td [ rnd ] td [ rnd ] td [ rnd ] td ] tr + ] table +
Added rosetta_code/documentation.rx version [e0b71f3dd2c940d9]
@@ -0,0 +1,20 @@
+Retro allows for insertion of documentation blocks. The contents of these can be
+in any format desired, though the standard Retro system uses Restructured Text for
+all embedded and external documentation.
+
+ doc{
+ =============
+ Function: foo
+ =============
+
+ Stack
+ ----
+ a1 a2 - b
+
+ Usage
+ -----
+ Adds a1 to a2 returning b.
+ }doc
+
+ : foo ( aa-b ) + ;
+
Added rosetta_code/empty_string.rx version [9d4eb5357b09bb06]
@@ -0,0 +1,23 @@ +Create an empty string and assign it to a variable. In these keepString is +used to ensure that the string is permanent. + + ( by creating a variable ) + "" keepString variable: foo + + ( by setting an existing variable 'foo' ) + "" keepString !foo + +Checking that a string is empty. A string with a length of zero is assumed to be empty. + + : emtpy? ( $-f ) getLength 0 = ; + + "" empty? putn + "hello" empty? putn + +Check that a string is not empty. + + : notEmpty? ( $-f ) getLength 0 > ; + + "" notEmpty? putn + "hello" notEmpty? putn +
Added rosetta_code/execute_brainf___.rx version [b63bee2f1e5b8a7c]
@@ -0,0 +1,155 @@
+ ( Ngaro Assembler ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
+ ( Copyright [c] 2008 - 2011, Charles Childers )
+ ( Copyright [c] 2009 - 2010, Luke Parrish )
+ ( Copyright [c] 2010, Marc Simpson )
+ ( Copyright [c] 2010, Jay Skeer )
+ ( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
+
+ 8000 constant MAX-APP-SIZE
+
+ ( Assembler ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
+ 3 elements target origin fid
+ : pad ( - ) @origin 32 + !target ;
+ : m, ( n- ) @target !+ !target ;
+ : vm: ( n"- ) ` : .data ` m, ` ; ;
+ 0 vm: nop, 1 vm: lit, 2 vm: dup,
+ 3 vm: drop, 4 vm: swap, 5 vm: push,
+ 6 vm: pop, 7 vm: loop, 8 vm: jump,
+ 9 vm: ret, 10 vm: >jump, 11 vm: <jump,
+ 12 vm: !jump, 13 vm: =jump, 14 vm: @,
+ 15 vm: !, 16 vm: +, 17 vm: -,
+ 18 vm: *, 19 vm: /mod, 20 vm: and,
+ 21 vm: or, 22 vm: xor, 23 vm: <<,
+ 24 vm: >>, 25 vm: 0; 26 vm: 1+,
+ 27 vm: 1-, 28 vm: in, 29 vm: out,
+ 30 vm: wait,
+
+ : t-here ( -n ) @target @origin - ;
+
+ {{
+ : writeByte ( n- )
+ @fid ^files'write drop ;
+
+ : applyMask ( n- )
+ %00000000000000000000000011111111 and ;
+
+ : writeCell ( n- )
+ dup applyMask writeByte
+ 8 >> dup applyMask writeByte
+ 8 >> dup applyMask writeByte
+ 8 >> applyMask writeByte ;
+ ---reveal---
+ : saveImage ( - )
+ "appImage" ^files':W ^files'open !fid
+ @origin t-here [ @+ writeCell ] times drop
+ @fid ^files'close drop bye ;
+ }}
+
+ : endApp ( - )
+ t-here "\nApp ends @ %d\n" puts
+ MAX-APP-SIZE t-here - "%d cells free" puts
+ depth 1 >= [ "\nError in stack depth!: " puts .s ] ifTrue ;
+ : :main ( - ) t-here [ "\nMAIN @ %d" puts ] [ @origin 1+ ! ] bi ;
+ : # ( n- ) lit, m, ;
+ : __# ( $- ) lit, toNumber m, ; parsing
+ : $, ( $- ) withLength [ @+ m, ] times 0 m, drop ;
+
+ : __: ( $- ) header t-here @last !d->xt ; parsing
+ : call ( "- ) ' m, ;
+ : jump ( "- ) 8 m, ' m, ;
+
+ ( Setup target memory for new image ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
+ here [ !target ] [ !origin ] bi MAX-APP-SIZE allot
+ jump, 0 m, pad
+ reset
+
+
+ ( Support functions: basic input, output, and data pointer support )
+ :wait
+ #0 #0 out,
+ wait,
+ ret,
+
+ :bye
+ #-9 #5 out,
+ ret,
+
+ :dp 32768 m,
+
+ :bf_>
+ dp # @,
+ 1+,
+ dp # !,
+ ret,
+
+ :bf_<
+ dp # @,
+ 1-,
+ dp # !,
+ ret,
+
+ :bf_+
+ dp # @, @,
+ 1+,
+ dp # @, !,
+ ret,
+
+ :bf_-
+ dp # @, @,
+ 1-,
+ dp # @, !,
+ ret,
+
+ :bf_.
+ dp # @, @,
+ #1 #2 out,
+ call wait
+ #0 #3 out,
+ ret,
+
+ :bf_,
+ #1 #1 out,
+ call wait
+ #1 in,
+ dp # @, !,
+ ret,
+
+ ( Actual BrainF*** compiler )
+ variable ip
+
+ : run
+ t-here putn space @ip @ putc cr
+ @ip @ ip ++
+ [ '> = ] [ drop bf_> m, ] when
+ [ '< = ] [ drop bf_< m, ] when
+ [ '+ = ] [ drop bf_+ m, ] when
+ [ '- = ] [ drop bf_- m, ] when
+ [ '. = ] [ drop bf_. m, ] when
+ [ ', = ] [ drop bf_, m, ] when
+ [ '[ = ] [ drop t-here dp # @, @, lit, 0 m, =jump, @target 0 m, ] when
+ [ '] = ] [ drop swap jump, m, t-here swap ! ] when
+ drop ;
+
+ : do
+ [ run @ip @ ] while ;
+
+ : bf: ( "- )
+ '~ accept tib keepString !ip cr do ;
+
+ ( Start Compilation of BrainF*** code after this )
+ :main
+
+Apart from support code, the actual compiler is implemented in the run function.
+This accepts sources like:
+
+ bf: >+++++++++[<++++++++>-]<.>+++++++[<++++>-]<+.+++++++..+++.[-]>++++++++[<++++>-]~
+ bf: <.>+++++++++++[<+++++>-]<.>++++++++[<+++>-]<.+++.------.--------.[-]>++++++++[~
+ bf: <++++>-]<+.[-]++++++++++.~
+
+ endApp
+ saveImage
+
+And upon completion a new appImage file is created. This can be run from the command line, using the --image command line argument:
+
+ ./retro --image appImage
+
Added rosetta_code/guess_the_number.rx version [6e70d6119f897d83]
@@ -0,0 +1,12 @@ +: checkGuess ( gn-gf || f ) + over = [ drop 0 ] [ "Sorry, try again!\n" puts -1 ] if ; + +: think ( -n ) + random abs 10 mod 1+ ; + +: guess ( - ) + "I'm thinking of a number between 1 and 10.\n" puts + "Try to guess it!\n" puts + think [ getToken toNumber checkGuess ] while + "You got it!\n" puts ; +