Artifact 7d251f1cabd66316f6f26b582b28e83880ceaa80
File master_theorem/synesthesia.rx part of check-in [48a095494d] - more master theorem solutions by crc on 2011-09-05 15:12:40. [annotate]
( The first part of the puzzle is a table, with six rows of six )
( characters. We'll create a table to hold this data: )
: table: ( n"- )
create [ getToken @ , ] times ;
( First up, a helper function that'll parse and build the tables. )
( Pass it a count, and follow it by the table name, then a )
( whitespace delimited series of tokens. )
36 table: initial A B C D E F
G H I J K L
M N O P Q R
S T U V W X
Y Z 0 1 2 3
4 5 6 7 8 9
( The initial table. This is an exact match to the table shown. )
36 table: colors 1 2 3 4 2 5
6 7 8 6 3 1
9 5 0 5 7 A
B C Q C D 4
8 7 0 4 B 3
7 D Q 5 A 9
( The table of characters has colors. Each color is matched to )
( two characters. We have a second table with values that )
( represent the color arrangement. )
: clue ( -$ )
"25 BACON BITS VANILLA 29 BROWNIES AND ALLSPICE 2" ;
( Below the table is a string of text that encodes the answer to )
( this puzzle. We create a string named "clue" to hold this. )
: withToken ( $q- )
[ " " ^strings'prepend " " ^strings'append ] dip
[ [ 32 ^strings'splitAtChar ^strings'chop ] dip [ do ] sip over 1 <> ] while 2drop ;
( You aren't expected to understand this. Breaking it down: )
[ " " ^strings'prepend " " ^strings'append ] dip
( Adds a space before and after the string passed to the )
( withToken function. This simplifies the following bits of code. )
[ [ 32 ^strings'splitAtChar ^strings'chop ] dip [ do ] sip over 1 <> ] while 2drop ;
( This isn't too complex. Breaking it down further: )
[ .... ] while 2drop
( Everything is inside a while loop. The 2drop removes the )
( pointers when execution is finished. )
[ 32 ^strings'splitAtChar ^strings'chop ] dip
( Inside the loop, this temporarily hides the quote, splits )
( a whitespace delimited token off the string, and removes )
( the trailing space with ^strings'chop. )
[ do ] sip
( Execute the quote, keeping a copy of the pointer on the stack after )
( execution completes. )
over 1 <>
( The condition for the while loop. When no tokens remain, the pointer )
( value will be returned as "1". So if not 1, there are more tokens to )
( process. )
( In actual use, this is pretty nice. It means you can do things like: )
"hello 123 again" [ "Token: %s\n" puts ] withToken
( The quote will be executed once for each word in the string. Now, )
( back to the solution. )
: append
dup isNumber? [ [ @ ^buffer'add ] ^types'STRING each@ ]
[ @ ^buffer'add ] if ;
( This is a factor of the simplify function which we'll look at next. )
( It looks at a token to see if it's a number or a word. If it's a )
( number, each character in the string is added to a buffer. If it's a )
( word, then only the first character is added. )
( Note the use of each@, another combinator which allows a quote to be )
( executed for each item in a data structure. )
: simplify ( $-$ )
heap [ here ^buffer'set 128 allot
&append withToken ] preserve
^buffer'start ;
( The rules of the puzzle dictate that each numeric digit has a color, )
( and each word has a color. simplify compresses a string into just the)
( relevant subset. To break this down: )
heap [ ... ] preserve
( We'll use the heap as a buffer. Encasing the code using this buffer )
( in a preservation quote cleans up any allocations when we are done. )
here ^buffer'set
( Sets the buffer to the heap. )
128 allot
( Allocates space for our buffer. This will be rolled back after )
( preserve is executed. )
&append withToken
( Applies the append function to each token in a string. We could also )
( have specified this as: )
[ append ] withToken
( The & syntax is a shortcut for single-function quotes. )
^buffer'start
( When execution of simplify finishes, we'll return a pointer to the )
( buffer we created. )
: getIndex ( c-n )
initial [ [ @ over <> ] sip 1+ swap ] while nip initial - 1- ;
( Lookup a character in the initial array, and return the index value )
( for later use. )
: colorize ( $-$ )
simplify
"" tempString ^buffer'set
[ @ getIndex colors + @ ^buffer'add ] ^types'STRING each@ ^buffer'start ;
( Convert a raw string into a colored one. )
simplify
( Start by reducing to just the relevant data. )
"" tempString ^buffer'set
( Create an empty string to use as a buffer. )
[ @ getIndex colors + @ ^buffer'add ] ^types'STRING each@
( Use each@ to apply a quote to each character in the simplified )
( string. For each character, we find the index, lookup the )
( corresponding character in the colors array, and add that to the new )
( string. )
^buffer'start
( Returns the colored string. )
( We're almost there. All we need to do is decode the colored string. )
: match? ( n-nf )
[ colors + @ over = ] sip swap ;
: matches
[ @ 36 [ match? [ initial + @ putc ] [ drop ] if ] iter drop space ] ^types'STRING each@ ;
( This is a quick hack to remap a color to all matching characters. )
( Since each color corresponds to two characters, this will display )
( pairs of characters. )
( With this, we can do: )
clue colorize matches
( And we get the following output: )
( S2 W5 BE BE TV S2 M9 BE AL AL S2 )
( From this, it's easy to deduce the solution: )
( S W E E T S M E L L S )
( Or: )
( SWEET SMELLS )