Re: Factor

Colored Timestamps

2012-01-25T18:24:00.000-08:00

I noticed a fun post in early December that implements a mapping between current time and a "unique" RGBA color. I thought it might be fun to use Factor to implement a colored clock.

The basic concept is to map the 4,294,967,296 unique RGBA colors to seconds, which gives just over 136 years of unique colors.

timestamp>rgba

We calculate timestamps as an offset from Dennis Ritchie's birthday:

: start-date ( -- timestamp )
    1941 9 9 <date> ; inline

The offset is an elapsed number of seconds from the start date:

: elapsed ( timestamp -- seconds )
    start-date time- duration>seconds >integer ;

The conversion from a timestamp into a unique RGBA color does successive divmod operations to map into Red, Green, Blue, and Alpha values:

: timestamp>rgba ( timestamp -- color/f )
    elapsed dup 0 32 2^ between? [
        24 2^ /mod 16 2^ /mod 8 2^ /mod
        [ 255 /f ] 4 napply <rgba>
    ] [ drop f ] if ;

You can try it for yourself, showing how the values change over time:

IN: scratchpad start-date timestamp>rgba .
T{ rgba
    { red 0.0 }
    { green 0.0 }
    { blue 0.0 }
    { alpha 0.0 }
}

IN: scratchpad now timestamp>rgba .
T{ rgba
    { red 0.5176470588235295 }
    { green 0.3803921568627451 }
    { blue 0.4313725490196079 }
    { alpha 0.3333333333333333 }
}

<rgba-clock>

Let's use the timestamp>rgba word to make an updating "colored clock". Specifically, we can use an arrow model to update a label every second to create an RGBA clock:

: update-colors ( color label -- )
    [ font>> background<< ]
    [ [ <solid> ] dip [ interior<< ] [ boundary<< ] 2bi ]
    2bi ;

: <rgba-clock> ( -- gadget )
    f <label-control>
        time get over '[
            [ timestamp>rgba _ update-colors ]
            [ timestamp>hms ] bi
        ] <arrow> >>model
        "HH:MM:SS" >>string
        monospace-font >>font ;

Use the gadget. word to try it in your listener, and watch it update:

IN: scratchpad <rgba-clock> gadget.

The code for this is on my Github.

Friday the 13th

2012-01-13T16:07:00.000-08:00

In honor of January 13, 2012, a Friday the 13th, I thought it might be fun to use Factor to explore similar dates in past and future history. According to Wikipedia, such a day "occurs at least once, but at most three times a year".

friday-13th?

A day is "Friday the 13th" if it is both (a) Friday and (b) the 13th:

: friday-13th? ( timestamp -- ? )
    [ day>> 13 = ] [ friday? ] bi and ;

Trying it for today and tomorrow, to make sure it works:

IN: scratchpad now friday-13th? .
t

IN: scratchpad : tomorrow ( -- timestamp )
                   now 1 days time+ ;

               tomorrow friday-13th? .
f

friday-13ths

Getting all Friday the 13th's for a given year:

: friday-13ths ( year -- seq )
    12 [0,b) [
        13 <date> dup friday? [ drop f ] unless
    ] with map sift ;

Or, for a range of years:

: all-friday-13ths ( start-year end-year -- seq )
    [a,b] [ friday-13ths ] map concat ;

Trying it for 2012:

IN: scratchpad 2012 friday-13ths .
{
    T{ timestamp
        { year 2012 }
        { month 1 }
        { day 13 }
    }
    T{ timestamp
        { year 2012 }
        { month 4 }
        { day 13 }
    }
    T{ timestamp
        { year 2012 }
        { month 7 }
        { day 13 }
    }
}

next-friday-13th

We can iterate, looking for the next Friday the 13th:

: next-friday-13th ( timestamp -- date )
    dup day>> 13 >= [ 1 months time+ ] when 13 >>day
    [ dup friday? not ] [ 1 months time+ ] while ;

Trying it for today, shows the next Friday the 13th is April, 13, 2012:

IN: scratchpad now next-friday-13th .
T{ timestamp
    { year 2012 }
    { month 4 }
    { day 13 }
}

The code (and some tests) for this is on my Github.

Duplicate Files

2012-01-03T18:45:00.000-08:00

A few months ago, Jon Cooper wrote a duplicate file checker in Go and Ruby.

Below, I contribute a simple version in Factor that runs faster than both Go and Ruby solutions. In the spirit of the original article, I have separated the logic into steps.

Argument Parsing

The command-line vocabulary gives us the arguments passed to the script. We check for the verbose flag and the root directory to traverse:

: arg? ( name args -- args' ? )
    2dup member? [ remove t ] [ nip f ] if ;

: parse-args ( -- verbose? root )
    "--verbose" command-line get arg? swap first ;

Filesystem Traversal

We can traverse the filesystem with the each-file word (choosing breadth-first instead of depth-first). In our case, we want to collect these files into a map of all paths that share a common filename:

: collect-files ( path -- assoc )
    t H{ } clone [
        '[ dup file-name _ push-at ] each-file
    ] keep ;

Our duplicate files are those files that share a common filename:

: duplicate-files ( path -- dupes )
    collect-files [ nip length 1 > ] assoc-filter! ;

MD5 Hashing Files

Using the checksums.md5 vocabulary, it is quite simple:

: md5-file ( path -- string )
    md5 checksum-file hex-string ;

Printing Results

If verbose is selected, then we print each filename and the MD5 checksum for each full path:

: print-md5 ( name paths -- )
    [ "%s:\n" printf ] [
        [ dup md5-file "  %s\n    %s\n" printf ] each
    ] bi* ;

We put this all together by calculating the possible duplicate files, optionally printing verbose MD5 checksums, and then print the total number of duplicates detected:

: run-dupe ( -- )
    parse-args duplicate-files swap
    [ dup [ print-md5 ] assoc-each ] when
    assoc-size "Total duped files found: %d\n" printf ;

Performance

I tested performance using two directory trees, one with over 500 files and another with almost 36,000 files. While the original article focuses more on syntax than speed, it is nice to see that the Factor solution is faster than the Go and Ruby versions.

Duplicates Factor Go Ruby
583 1.453 2.298 3.861
35,953 19.084 24.452 30.597
The above time is seconds on my laptop.

Duplicates	Factor	Go	Ruby
583	1.453	2.298	3.861
35,953	19.084	24.452	30.597

The code for this is on my Github.

Picomath

2011-12-31T16:08:00.000-08:00

The Picomath project holds some reusable math functions inspired by John D. Cook's Stand-alone code for numerical computing, including:

Error function
Phi (standard normal CDF)
Phi inverse
Gamma
Log Gamma
exp(x) - 1 (for small x)
log(n!)

These functions are implemented in an impressive list of languages: Ada, C++, C#, D, Erlang, Go, Haskell, Java, Javascript, Lua, Pascal, Perl, PHP, Python (2.x and 3.x), Ruby, Scheme, and Tcl.

And now Factor!

You can find the code (and a bunch of tests) for this on my Github.

Slot Machines

2011-12-30T14:48:00.000-08:00

Playing slot machines can be pretty fun, but don't be fooled by claims that the casino has the "loosest slots", odds are probably still against you. I thought it would be fun (and cheaper!) to build a slot machine simulator using Factor.

Our slot machine is going to be a console application that will look something like this:

Spinning

Even though our slot machine is text-only, we can still make use of some nice unicode characters to be our symbols:

CONSTANT: SYMBOLS "☀☁☂☃"

Each spin chooses a different symbol at random (each being equally likely):

: spin ( value -- value' )
    SYMBOLS remove random ;

To reproduce the feel of spinning a slot machine, we will introduce a slight delay so that the wheel spins fast at the beginning and then slower and slower until it stops on a symbol:

: spin-delay ( n -- )
    15 * 25 + milliseconds sleep ;

Spinning the slot machine takes a spin number, delays for a bit, then rotates each wheel (we stop spinning the first column after 10 spins, the second after 15, and the last after 20):

: spin-slots ( a b c n -- a b c )
    {
        [ spin-delay ]
        [ 10 < [ [ spin ] 2dip ] when ]
        [ 15 < [ [ spin ]  dip ] when ]
        [ drop spin ]
    } cleave ;

Display

Each "spin" of the slot machine will be printed out. Using ANSI escape sequences, we move the cursor to the top left ("0,0") of the screen and then issue a clear screen instruction. Then we print out the current display and flush the output to screen:

: print-spin ( a b c -- a b c )
    "\e[0;0H\e[2J" write
    "Welcome to the Factor slot machine!" print nl
    "  +--------+" print
    "  | CASINO |" print
    "  |--------| *" print
    3dup "  |%c |%c |%c | |\n" printf
    "  |--------|/" print
    "  |    [_] |" print
    "  +--------+" print flush ;

Playing

The player will have won if, after all the spins, the "pay line" shows three of the same characters:

: winner? ( a b c -- )
    3array all-equal? nl "You WIN!" "You LOSE!" ? print nl ;

Playing the slot machine consists of spinning the wheels 20 times, displaying each spin to the user, then checking if the user has won the game.

: play-slots ( -- )
    f f f 20 iota [ spin-slots print-spin ] each winner? ;

Since our casino wants the user to keep playing, we make it really easy to just hit ENTER to continue:

: continue? ( -- ? )
    "Press ENTER to play again." write flush readln ;

And, to finish it off, we define a "MAIN" entry point that will be run when the script is executed:

: main-slots ( -- )
    [ play-slots continue? ] loop ;

MAIN: main-slots

The code for this is on my Github.

Elementology

2011-12-28T12:56:00.000-08:00

Question: What do the words bamboo, crunchy, finance, genius, and tenacious have in common? I'll give you a hint: its the same thing they have in common with the words who, what, when, where, and how?

Stumped? Well, it's not that these are all English words.

Answer: All of these words can be spelled using elements from the periodic table!

I was recently inspired by the Periodic GeNiUS T-shirt from ThinkGeek and a website that can "make any words out of elements in the periodic table". I thought it would be fun to use Factor to see how many other words can be spelled using the symbols for chemical elements.

First, we need a list of elements:

: elements ( -- assoc )
    H{
        { "H" "Hydrogen" }
        { "He" "Helium" }
        { "Li" "Lithium" }
        { "Be" "Beryllium" }
        { "B" "Boron" }
        { "C" "Carbon" }
        ...
        { "Uut" "Ununtrium" }
        { "Uuq" "Ununquadium" }
        { "Uup" "Ununpentium" }
        { "Uuh" "Ununhexium" }
        { "Uus" "Ununseptium" }
        { "Uuo" "Ununoctium" }
    } [ [ >lower ] dip ] assoc-map ;

Next, a word that checks if a particular substring is the symbol of an element:

: element? ( from to word -- ? )
    2dup length > [ 3drop f ] [ subseq elements key? ] if ;

We know that symbols are only ever one, two, or three characters. A word is considered "periodic" if it can be composed of any number of (possibly repeating) element symbols. We build a recursive solution that starts with the first character and continues as long as element symbols are a match or until the end of the word is reached:

: (periodic?) ( word from -- ? )
    {
        [ swap length = ]
        [
            { 1 2 3 } [
                dupd + [ pick element? ] keep
                '[ dup _ (periodic?) ] [ f ] if
            ] with any? nip
        ]
    } 2|| ;

: periodic? ( word -- ? )
    >lower 0 (periodic?) ;

It's easy to get a list of dictionary words from most Unix systems:

: dict-words ( -- words )
    "/usr/share/dict/words" ascii file-lines ;

And then a list of all "periodic words":

: periodic-words ( -- words )
    dict-words [ periodic? ] filter ;

So, how many words are "periodic words"? About 13.7% of them.

IN: scratchpad dict-words length .
235886

IN: scratchpad periodic-words length .
32407

The code for this is on my Github.

wc -l

2011-11-10T14:45:00.001-08:00

The wc program is a utility that can count the number of lines in a file. It has a number of options that are described on its man page that can change its function to count characters or word or produce the length of the longest line.

For the last month, Joe Groff has been improving the performance of Factor's I/O libraries. Yesterday, we were investigating slow performance when doing lots of small reads from a file. Joe was able to make a number of nice speedups, which will be in the next release of Factor.

After suggesting that we use wc -l as a benchmark to aspire to, we came up with several approaches with varying performance. I want to demonstrate these, using timing information from running it on my computer. Although the Factor image file is binary data, we are going to count the number of newline characters in it.

Note: some of these require the latest development version of Factor to run.

Our "gold standard" will be wc -l, which takes just over 0.1 seconds:

$ time wc -l factor.image
 6149212 factor.image

real 0m0.111s
user 0m0.090s
sys  0m0.020s

Our first attempt in Factor is the shortest amount of code but takes 5.8 seconds (you can time this by running "USE: system [ image wc-file-lines ] time"):

: wc-file-lines ( path -- n )
    binary file-lines length ;

We don't really need the lines, just their count, so perhaps just increment each-line in a loop. This is an improvement at just over 3 seconds:

: wc-each-line ( path -- n )
    binary [ 0 [ drop 1 + ] each-line ] with-file-reader ;

Trying to use read-until to look for the next newline, is a bit slower at 3.4 seconds:

: wc-read-until ( path -- n )
    binary [
        0 [ "\n" read-until [ drop 1 + ] dip ] loop
    ] with-file-reader ;

Instead of reading each line at a time, we can just read 65,536 byte blocks and count the number of newlines. This takes about 1.5 seconds:

: wc-each-block ( path -- n )
    binary [
        0 [ [ CHAR: \n = ] count + ] each-block
    ] with-file-reader ;

Since we are only counting characters in each block, we don't need to allocate and copy the bytes out of the I/O buffer. Instead, we can look at a slice. This takes about 1 second:

: wc-each-block-slice ( path -- n )
    binary [
        0 [ [ CHAR: \n = ] count + ] each-block-slice
    ] with-file-reader ;

The stream functions (such as read) operate on an input-stream dynamic variable, which introduces some overhead. If we remove that, the compiler can eliminate some of the dynamic dispatches. taking 0.320 seconds:

: wc-fast ( path -- n )
    binary <file-reader> [
        0 swap [
            [ CHAR: \n = ] count +
        ] each-stream-block-slice
    ] with-disposal ;

If we make an assumption that the number of lines in a file will fit into a fixnum, then we can get a bit faster at 0.240 seconds:

: wc-faster ( path -- n )
    binary <file-reader> [
        0 swap [
            [ CHAR: \n = ] count + >fixnum
        ] each-stream-block-slice
    ] with-disposal ;

And, if we cheat and just run the wc -l process directly, we can get to 0.210 seconds:

: wc-system ( path -- n )
    "wc -l " prepend utf8 [
        readln " " split harvest first string>number
    ] with-process-reader ;

Overall, not too bad! Factor is getting within shouting distance of programs written in "faster" languages. Probably with a few more hours, we could close the gap, but thats enough for today.

Update: using SIMD, Joe was able to get the time down to 0.120 seconds!

: aligned-slices ( seq -- head tail )
   dup length 15 bitnot bitand cut-slice ; inline

: wc-simd ( path -- n )
   [
       0 swap binary <file-reader> &dispose [
           aligned-slices [
               uchar-16 cast-array swap
               [ 10 uchar-16-with v= vcount + >fixnum ] reduce
           ] [ [ 10 = ] count + >fixnum ] bi*
       ] each-stream-block-slice
   ] with-destructors ;

Disassemble

2011-10-26T11:34:00.000-07:00

A neat trick that Factor provides is the ability to disassemble functions into the machine code that is generated by the compiler. In 2008, Slava Pestov created a disassembler, and has improved it a bit since then (switching to udis86 for its implementation).

Constant Folding

The compiler performs constant folding, using the compiler.tree.debugger vocabulary, you can output the optimized form of a quotation:

( scratchpad ) [ 2 2 + ] optimized.
[ 4 ]

Using the disassembler, you can see the machine code this generates:

( scratchpad ) [ 2 2 + ] disassemble
011c1a5530: 4983c608        add r14, 0x8
011c1a5534: 49c70640000000  mov qword [r14], 0x40
011c1a553b: c3              ret 
011c1a553c: 0000            add [rax], al
011c1a553e: 0000            add [rax], al

Local Variables

One of the questions that comes up sometimes is whether local variables affect performance. We can examine two words that add numbers together, one using locals and one just using the stack:

( scratchpad ) : foo ( x y -- z ) + ;

( scratchpad ) :: bar ( x y -- z ) x y + ;

The "optimized output" looks a little different:

( scratchpad ) \ foo optimized.
[ + ]

( scratchpad ) \ bar optimized.
[ "COMPLEX SHUFFLE" "COMPLEX SHUFFLE" R> + ]

But, the machine code that is generated is identical:

( scratchpad ) \ foo disassemble
01115de7b0: 488d1d05000000  lea rbx, [rip+0x5]
01115de7b7: e9e49439ff      jmp 0x110977ca0 (+)
01115de7bc: 0000            add [rax], al
01115de7be: 0000            add [rax], al

( scratchpad ) \ bar disassemble
01115ef620: 488d1d05000000  lea rbx, [rip+0x5]
01115ef627: e9748638ff      jmp 0x110977ca0 (+)
01115ef62c: 0000            add [rax], al
01115ef62e: 0000            add [rax], al

Dynamic Variables

Another frequently used feature is dynamic variables, implemented by the namespaces vocabulary. For example, the definition of the print word looks for the current value of the output-stream variable and then calls stream-print on it:

( scratchpad ) \ print see
USING: namespaces ;
IN: io
: print ( str -- ) output-stream get stream-print ; inline

The optimized output inlines the implementation of get:

( scratchpad ) [ "Hello, world" print ] optimized.
[
    "Hello, world" \ output-stream 0 context-object assoc-stack
    stream-print
]

You can inspect the machine code generated, seeing references to the factor words that are being called:

( scratchpad ) [ "Hello, world" print ] disassemble
011c0c6c40: 4c8d1df9ffffff        lea r11, [rip-0x7]
011c0c6c47: 6820000000            push dword 0x20
011c0c6c4c: 4153                  push r11
011c0c6c4e: 4883ec08              sub rsp, 0x8
011c0c6c52: 4983c618              add r14, 0x18
011c0c6c56: 48b8dbc5a31a01000000  mov rax, 0x11aa3c5db
011c0c6c60: 498946f0              mov [r14-0x10], rax
011c0c6c64: 498b4500              mov rax, [r13+0x0]
011c0c6c68: 488b4040              mov rax, [rax+0x40]
011c0c6c6c: 498906                mov [r14], rax
011c0c6c6f: 48b86c91810e01000000  mov rax, 0x10e81916c
011c0c6c79: 498946f8              mov [r14-0x8], rax
011c0c6c7d: e8de4e36ff            call 0x11b42bb60 (assoc-stack)
011c0c6c82: 4883c418              add rsp, 0x18
011c0c6c86: 488d1d05000000        lea rbx, [rip+0x5]
011c0c6c8d: e94e5264ff            jmp 0x11b70bee0 (stream-print)
011c0c6c92: 0000                  add [rax], al
011c0c6c94: 0000                  add [rax], al
011c0c6c96: 0000                  add [rax], al
011c0c6c98: 0000                  add [rax], al
011c0c6c9a: 0000                  add [rax], al
011c0c6c9c: 0000                  add [rax], al
011c0c6c9e: 0000                  add [rax], al

Optimizing 2^x

2011-10-12T22:59:00.000-07:00

A great little article was posted last year about optimizing 2^x for doubles (by approximation). The author gets 40+% performance improvements in C#. I wondered if we could get similar improvements in Factor.

The basic idea is to use the fact that a number, a^b+c can be factored into a^b * a^c. If we separate a floating point number into two components: an integer and a fractional part, we can show that:

2ⁿ = 2^integer(n) * 2^{fractional(n)}.

We are going to approximate this value by using a lookup table to compute the fractional part (within a specified precision). For example, to compute within a 0.001 precision, we need 1000 lookup values, essentially performing this calculation:

2ⁿ = ( 1 << Int(n) ) * Table[ (int) ( Frac(n) * 1000 ) ];

Implementation

So, we need a word that can split a floating point number into those two values:

: float>parts ( x -- float int )
    dup >integer [ - ] keep ; inline

Instead of one table with 1000 values, we will copy the original authors decision to use three lookup tables for additional precision. The following code calculates these lookup tables:

CONSTANT: BITS1 10
CONSTANT: BITS2 $[ BITS1 2 * ]
CONSTANT: BITS3 $[ BITS1 3 * ]

CONSTANT: PRECISION1 $[ 1 BITS1 shift ]
CONSTANT: PRECISION2 $[ 1 BITS2 shift ]
CONSTANT: PRECISION3 $[ 1 BITS3 shift ]

CONSTANT: MASK $[ PRECISION1 1 - ]

CONSTANT: FRAC1 $[ 2 PRECISION1 iota [ PRECISION1 / ^ ] with map ]
CONSTANT: FRAC2 $[ 2 PRECISION1 iota [ PRECISION2 / ^ ] with map ]
CONSTANT: FRAC3 $[ 2 PRECISION1 iota [ PRECISION3 / ^ ] with map ]

The function pow2 looks pretty similar to our original mathematical definition:

: pow2 ( n -- 2^n )
    >float 2^int 2^frac * >float ;

The guts of the implementation is in the 2^int and 2^frac words:

: 2^int ( n -- 2^int frac )
    [ float>parts ] keep 0 >= [ 1 swap shift ] [
        over 0 < [ [ 1 + ] [ 1 - ] bi* ] when
        1 swap neg shift 1.0 swap /
    ] if swap ; inline

: 2^frac ( frac -- 2^frac )
    PRECISION3 * >fixnum
    [ BITS2 neg shift FRAC1 nth-unsafe ]
    [ BITS1 neg shift MASK bitand FRAC2 nth-unsafe ]
    [ MASK bitand FRAC3 nth-unsafe ] tri * * ; inline

Testing

Let's try it and see how well it works for small values:

( scratchpad ) 2 1.5 ^ .
2.82842712474619

( scratchpad ) 1.5 pow2 .
2.82842712474619

It seem's to work, how about larger values:

( scratchpad ) 2 16.3 ^ .
80684.28027297248

( scratchpad ) 16.3 pow2 .
80684.28026255539

The error is clearly detectable, but to test that it really works the way we expect it too, we will need to calculate relative error:

: relative-error ( approx value -- relative-error )
    [ - abs ] keep / ;

Our test case will generate random values, compute 2^x using our approximation and verify the relative error is less than 0.000000001 when compared with the correct result:

[ t ] [
    10000 [ -20 20 uniform-random-float ] replicate
    [ [ pow2 ] [ 2 swap ^ ] bi relative-error ] map
    supremum 1e-9 <
] unit-test

And to verify performance, we will benchmark it against the built-in (and more accurate ^ word):

: pow2-test ( seq -- new old )
    [ [ pow2 drop ] [ each ] benchmark ]
    [ 2 swap [ ^ drop ] with [ each ] benchmark ] bi ;

We got almost a 40% performance improvement at the cost of a small loss of precision - not bad!

( scratchpad ) 10000 [ -20 20 uniform-random-float ] replicate
               pow2-test / >float .
0.6293153754782392

The code for this is on my Github.

Approximating Pi

2011-09-25T16:18:00.000-07:00

A few days ago, it was announced on the Wolfram Blog that a 13-year-old had made a record calculating 458 million terms for the continued fraction of pi. In the spirit of that, I thought I would show how to solve a question that sometimes gets asked at interviews:

Given that Pi can be estimated using the function 4 * (1 - 1/3 + 1/5 - 1/7 + ...) with more terms giving greater accuracy, write a function that calculates Pi to an accuracy of 5 decimal places.

Using Factor, we can calculate the nth approximation of pi using vector arithmetic:

: approximate-pi ( n -- approx )
    [1,b] 2 v*n 1 v-n 1 swap n/v
    [ odd? [ neg ] when ] map-index sum 4 * ;

This isn't ideal if we want to try an increasing number of terms (looking for a particularly accuracy), since a lot of the the work would be redone unnecessarily. Instead, we can write a word that adds successive terms until the difference between the previous approximation and the current approximation is less than our requested accuracy.

: next-term ( approx i -- approx' )
    [ 2 * 1 + ] [ odd? [ neg ] when ] bi 4.0 swap / + ; inline

:: find-pi-to ( accuracy -- n approx )
    1 4.0 [
        dup pick next-term [ - ] keep
        swap abs accuracy >= [ 1 + ] 2dip
    ] loop ;

To show its performance, we can time it:

( scratchpad ) [ 0.00001 find-pi-to ] time .
Running time: 0.026030341 seconds

3.141597653564762

An equivalent function in Python might look like this:

def find_pi_to(accuracy):
    i = 1
    approx = 4.0
    while 1:
        term = (2 * i) + 1
        if i % 2 == 1:
            term = -term
        new = approx + 4.0/term
        if abs(new - approx) < accuracy:
            approx = new
            break
        i += 1
        approx = new
    return approx

But, if we time this version (not counting startup or compile time), it takes 0.134 seconds. Doing the math shows that Factor is 5 times faster than Python in this case. Not bad.

Really Big Numbers

2011-09-22T17:32:00.000-07:00

Factor supports both fixnum (fixed size integers, typically 32- or 64-bit values) and bignum (arbitrarily large integers). Recently, I discovered that Factor did not have support for calculating the logarithm of really big numbers (those larger than 2¹⁰²⁴).

You can define a simple factorial function:

: factorial ( n -- n! )
    [ 1 ] [ [1,b] product ] if-zero ;

But if you tried to calculate the logarithm of 1000 factorial, it produces the wrong answer.

( scratchpad ) 1000 factorial log .
1/0.

The reason for this is that Factor attempts to convert a bignum into a double-precision floating point number and take the logarithm of that. Unfortunately, the value in this case is too large. What do other languages do in this case?

We could look at Ruby, but it has the same problem as Factor:

>> Math::log((1..1000).inject(:*))
(irb):8: warning: Bignum out of Float range
=> Infinity

However, you can get the right answer in Python:

>>> def factorial(n):
...    r = 1
...    while n > 0:
...        r *= n
...        n -= 1
...    return r
...
>>> math.log(factorial(1000))
5912.128178488163

If you look under the covers, you will see that Python handles this case by calling frexp to split a value into a fraction (x) and a power of two (exp). The original value can be calculated as x*2^exp. Using this, the logarithm can be computed as log(x) + log(2) * exp.

After discussing this on #concatenative, Joe Groff and I came up with a solution for this. I'm not going to go over all the details, but if you're curious, you can look at the discussion.

First, we implemented a cross-platform version of frexp:

GENERIC: frexp ( x -- y exp )

M: float frexp
    dup fp-special? [ dup zero? ] unless* [ 0 ] [
        double>bits
        [
            HEX: 800f,ffff,ffff,ffff bitand
            0.5 double>bits bitor bits>double
        ] [ -52 shift HEX: 7ff bitand 1022 - ] bi
    ] if ; inline

M: integer frexp
    [ 0.0 0 ] [
        dup 0 > [ 1 ] [ abs -1 ] if swap dup log2 [
            52 swap - shift HEX: 000f,ffff,ffff,ffff bitand
            0.5 double>bits bitor bits>double
        ] [ 1 + ] bi [ * ] dip
    ] if-zero ; inline

Next, we added support for log and log10 of bignum. If the number can be represented as a float, we continue to process it as before, but if it is larger, we calculate it similar to Python (with some caching of the log(2) and log10(2) values for performance):

: most-negative-finite-float ( -- x )
    HEX: -1.ffff,ffff,ffff,fp1023 >integer ; inline
: most-positive-finite-float ( -- x )
    HEX:  1.ffff,ffff,ffff,fp1023 >integer ; inline

CONSTANT: log-2   HEX: 1.62e42fefa39efp-1
CONSTANT: log10-2 HEX: 1.34413509f79ffp-2

: (representable-as-float?) ( x -- ? )
    most-negative-finite-float
    most-positive-finite-float between? ; inline

: (bignum-log) ( n log-quot: ( x -- y ) log-2 -- log )
    [ dup ] dip '[
        dup (representable-as-float?)
        [ >float @ ] [ frexp [ @ ] [ _ * ] bi* + ] if
    ] call ; inline

M: bignum log [ log ] log-2 (bignum-log) ;

M: bignum log10 [ log10 ] log10-2 (bignum-log) ;

And now, in the listener you can get the answer!

( scratchpad ) 1000 factorial log .
5912.128178488163

This change is now in the Factor repository (if you'd like to update), and will be in the next release.

Enigma Machines

2011-09-20T16:13:00.000-07:00

I noticed a fun blog post about recreating the Enigma machine in Python. For those who need a refresher, an Enigma machine was an encryption device used before and during World War II. I thought it would be fun to implement this in Factor.

Build It

Our alphabet will be the 26 letters in the English alphabet, indexed from 0 to 25 ("a" to "z"):

: <alphabet> ( -- seq )
    26 iota >array ;

The Enigma machine is made up of a number of "cogs", which contain an encoding. We will create a cog using a randomized alphabet:

: <cog> ( -- cog )
    <alphabet> randomize ;

We need to create a utility function to remove a random element from a sequence:

: remove-random ( seq -- elt seq' )
    [ length random ] keep [ nth ] [ remove-nth ] 2bi ;

A special rotor called a "reflector" connected pairs of outputs, ensuring that encryption and decryption were the same process. It also gave the Enigma machine the property that no letter encrypted to itself (a flaw which was used to help break the code). We can create a reflector by taking the alphabet, and randomly exchanging pairs of elements:

: <reflector> ( -- reflector )
    <alphabet> dup length iota [ dup empty? ] [
        remove-random remove-random [ pick exchange ] dip
    ] until drop ;

We can now create an Enigma machine with a number of cogs and a reflector:

TUPLE: enigma cogs prev-cogs reflector ;

: <enigma> ( num-cogs -- enigma )
    [ <cog> ] replicate dup clone <reflector> enigma boa ;

We need a way to check for special characters (those not in the 26 letter alphabet):

: special? ( n -- ? )
    [ 25 > ] [ 0 < ] bi or ;

We need a utility function to change several elements of a sequence at the same time:

: change-nths ( indices seq quot: ( elt -- elt' ) -- )
    [ change-nth ] 2curry each ; inline

Encoding a piece of text is where all the work is performed. The main strategy is to apply each character (that isn't special) through the cogs and then the reflector to find the encoded character, and then cycle the cogs to prepare for the next character.

:: encode ( text enigma -- cipher-text )
    0 :> ln!
    enigma cogs>> :> cogs
    enigma reflector>> :> reflector
    text >lower [
        CHAR: a mod dup special? [
            ln 1 + ln!
            cogs [ nth ] each reflector nth
            cogs reverse [ index ] each CHAR: a +
            cogs length iota [ 6 * 1 + ln mod zero? ] filter
            cogs [ unclip prefix ] change-nths
        ] unless
    ] map ;

Note: this converts the text to lowercase before encoding. The encode word could be expanded to support uppercase, but its much simpler this way.

If we make a word to reset the cogs back to the original configuration, we can verify that the encrypted text can be decrypted back to the original.

: reset-cogs ( enigma -- enigma )
    dup prev-cogs>> >>cogs ;

Try It

We can experiment with this in the Listener, creating a 4-cog Enigma machine and then encoding, resetting, and encoding again:

( scratchpad ) 4 <enigma>

( scratchpad ) "hello, world" over encode [ print ] keep
luhhn, xnzha

( scratchpad ) over reset-cogs encode print
hello, world

The code for this is on my Github.

Most Pressed Keys

2011-09-18T08:53:00.000-07:00

Mahdi Yusuf made a fun blog post about which keys get pressed the most in various programming languages. I thought I would generate one for Factor:

This was assembled by taking all the source code (not documentation or tests) from core/ and basis/ in the Factor codebase and passing it through heatmap.js.

Manipulating Files

2011-09-11T08:51:00.000-07:00

Java has had historically frustrating API's for interacting with files. In Java 7, these API's were cleaned up a little bit. A blog post demonstrates some examples of using these new API's. I would say, though, that Factor demonstrates a much simpler cross-platform API:

Creating and Deleting Files

To create a file, simply:

( scratchpad ) "/path/to/file" touch-file

To update file permissions (on unix systems), you can use the io.files.info.unix vocabulary:

( scratchpad ) "/path/to/file" OCT: 666 set-file-permissions

Note: it would be nice to support parsing "rw-rw-rw-" and "g+x" and similar permission strings, and probably not very difficult.

To delete a file, simply:

( scratchpad ) "/path/to/file" delete-file

Copying and Moving Files

To copy a file from one path to another:

( scratchpad ) "/path/from" "/path/to" copy-file

To copy a file, and preserve its file permissions:

( scratchpad ) "/path/from" "/path/to" copy-file-and-info

To copy a file into a directory:

( scratchpad ) "/dir1/file" "/dir2" copy-file-into

To move a file from one path to another:

( scratchpad ) "/path/from" "/path/to" move-file

To move a file into a directory:

( scratchpad ) "/dir1/file" "/dir2" move-file-into

echo

2011-09-06T19:14:00.000-07:00

One of the most basic unix utilities is echo, which is used to "display a line of text". Below, I show how to implement this in Factor.

The usage for echo is usually written like this:

echo [-n] [string ...]

The -n option is to "not print the trailing newline character". We can make a word that checks the first argument for -n, and returns a boolean and the remaining arguments for formatting:

: -n? ( args -- ? args' )
    [ first "-n" = ] keep over [ rest ] when ;

Since the string arguments are separated by a single blank space, we can join and write them, optionally printing a trailing newline.

: echo-args ( args -- )
    -n? " " join write [ nl ] unless ;

We can define a "main" word that allows our vocabulary to be directly run or deployed:

: run-echo ( -- )
    command-line get [ nl ] [ echo-args ] if-empty ;

MAIN: run-echo

The code for this is on my Github.

Fun with WAV

2011-09-03T11:25:00.000-07:00

Last year, a "Fun with wav" post got a lot of visibility. The author was trying to extract the header from a audio file in the WAV format and output the sum of the remaining data in the file. He gives the disclaimer several times that this was a specific hack and not a generalized solution.

Although the original solution was in C, he received other possible solutions on Reddit. The "winner" by code golf rules is probably Ruby:

data = ARGF.read
keys = %w[id totallength wavefmt format
          pcm channels frequency bytes_per_second
          bytes_by_capture bits_per_sample
          data bytes_in_data sum
]
values = data.unpack 'Z4 i Z8 i s s i i s s Z4 i s*'
sum = values.drop(12).map(&:abs).inject(:+)
keys.zip(values.take(12) << sum) {|k, v|
      puts "#{k.ljust 17}: #{v}"
}

Build It

While not attempting to "golf", I wanted to show how this might be implemented in Factor. First, some imports:

USING: alien.c-types classes.struct kernel io
io.encodings.binary io.files math specialized-arrays ;

FROM: sequences => map-sum ;

IN: wavsum

Each WAV file begins with a "master RIFF chunk" followed by format information and the sampled data. We could read each field specifically, or we can capture this header information directly into a packed structure (I added support for these in January and recently merged it into the main Factor repository).

PACKED-STRUCT: header
    { id char[4] }
    { totallength int }
    { wavefmt char[8] }
    { format int }
    { pcm short }
    { channels short }
    { frequency int }
    { bytes_per_second int }
    { bytes_by_capture short }
    { bits_per_sample short }
    { data char[4] }
    { bytes_in_data int } ;

We can easily read from an input stream directly into this structure:

: read-header ( -- header )
    header [ heap-size read ] [ memory>struct ] bi ;

The original solution then produced a sum of the remaining file, treated as a sequence of shorts (16-bit integers).

SPECIALIZED-ARRAY: short

: sum-contents ( -- sum )
    contents short-array-cast [ abs ] map-sum ;

Producing a "wavsum" from a file:

: wavsum ( path -- header sum )
    binary [ read-header sum-contents ] with-file-reader ;

Try It

We can try it on a sample wav file that I included with the vocabulary and we get the same output as the Ruby and C versions:

( scratchpad ) "vocab:wavsum/truck.wav" wavsum [ . ] bi@
S{ header
    { id char-array{ 82 73 70 70 } }
    { totallength 66888 }
    { wavefmt char-array{ 87 65 86 69 102 109 116 32 } }
    { format 50 }
    { pcm 2 }
    { channels 1 }
    { frequency 22050 }
    { bytes_per_second 10752 }
    { bytes_by_capture 512 }
    { bits_per_sample 4 }
    { data char-array{ 32 0 -12 3 } }
    { bytes_in_data 16777223 }
}
392717699

It might be useful to add some validation to this example (much like the original C version) for such things as endianness and the 16-bit WAV format. Alternatively, we could improve it to be more general to handle 8-bit or 24-bit encodings, as well as other header formats (not just the "extended WAV" format).

The code for this is on my Github.

Thesaurus

2011-08-28T10:22:00.000-07:00

Steve Hanov blogged about building a thesaurus using a "zero load time" file formats. Below, we translate his implementation into Factor.

You can download the 11 MB thesaurus data file we will be using (containing over 100,000 words and their lists of related words). It is implemented as a single file with a custom binary file format that looks like this:

[ header ]
4 bytes: number of words

[ index section ]
# The words are listed in alphabetical order, so you
# can look one up using binary search.
for each word:
    4 byte pointer to word record

[ word section ]
for each word:
   null terminated text
   4 bytes: number of related words
   for each link:
       pointer to linked word record

Build It

The data file consists of 4 byte "pointers" and null-terminated strings. We can build words to read an integer or a string from a particular location in the file:

: read-int ( ptr -- n )
    seek-absolute seek-input 4 read le> ;

: read-string ( ptr -- string )
    seek-absolute seek-input "\0" read-until drop >string ;

The number of words in the thesaurus is at the beginning of the file:

: #words ( -- n ) 0 read-int ;

The position of each word is found by reading the "nth" index:

: word-position ( n -- ptr ) 4 * 4 + read-int ;

The "nth" word is the string found at the specified word position:

: nth-word ( n -- word ) word-position read-string ;

Now for the fun part. Knowing that the index is sorted, we can build a word that performs a binary search for a particular word using the index.

:: find-word ( word -- n )
    #words :> high! -1 :> low! f :> candidate!
    [ high low - 1 > ] [
        high low + 2 /i :> probe
        probe nth-word candidate!
        candidate word <=> {
            { +eq+ [ probe high! probe low! ] }
            { +lt+ [ probe low! ] }
            [ drop probe high! ]
        } case
    ] while candidate word = [ high ] [ f ] if ;

Once we found the word that we are looking for, we can read its related words.

:: find-related ( word -- words )
    word find-word [
        word-position word length + 1 + :> ptr
        ptr read-int :> #related
        ptr #related [1,b] 4 v*n n+v
        [ read-int read-string ] map
    ] [ { } ] if* ;

Putting this all together, we can construct a file reader from the thesaurus file, a convenience word to run a quotation with the thesaurus as its input stream, and our "related words" function.

: <thesaurus-reader> ( -- reader )
    "vocab:thesaurus/thesaurus.dat" binary <file-reader> ;

: with-thesaurus ( quot -- )
    [ <thesaurus-reader> ] dip with-input-stream ; inline

: related-words ( word -- words )
    [ find-related ] with-thesaurus ;

Try It

If it is all working properly, you should be able to lookup the words that are related to any word that is in our thesaurus file.

( scratchpad ) "food" related-words .
{
    "aliment"
    "bread"
    "chow"
    "comestibles"
    "commons"
    "eatables"
    "eats"
    "edibles"
    "feed"
    "foodstuff"
    "foodstuffs"
    "grub"
    "meat"
    "nourishment"
    "nurture"
    "nutriment"
    "pabulum"
    "pap"
    "provender"
    "provisions"
    "rations"
    "scoff"
    "subsistence"
    "sustenance"
    "tuck"
    "viands"
    "victuals"
}

As for performance, it takes just over one millisecond on my laptop to lookup a single word. Not too shabby! The code for this is on my Github.

Successor

2011-08-24T12:38:00.000-07:00

A few days ago, I wrote about translating the humanize function from the slang.js "string utility" library into Factor. While looking through the other functions defined in that library, I came across the successor function.

The "successor" of a string is defined to be a kind of "alphanum increment". It's easiest to show a few examples of how it works:

successor("a")         == "b"
successor("1")         == "2"
successor("abcd")      == "abce"
successor("THX1138")   == "THX1139"
successor("<<koala>>") == "<<koalb>>"
successor("1999zzz")   == "2000aaa"
successor("ZZZ9999")   == "AAAA0000"

We are going to implement this in Factor, using the slang.js documentation as a guide:

"Returns the successor to str. The successor is calculated by incrementing characters starting from the rightmost alphanumeric (or the rightmost character if there are no alphanumerics) in the string. Incrementing a digit always results in another digit, and incrementing a letter results in another letter of the same case.
If the increment generates a carry, the character to the left of it is incremented. This process repeats until there is no carry, adding an additional character if necessary."

To start, we should handle the "carry" logic. There are two kinds of carries: digits and letters. Both involve checking if a character has exceeded a range (resetting it to the beginning of the range if it has). We can build a word that does this, returning the new character value as well as a boolean flag indicating if a carry occurred:

: carry ( elt last first -- ? elt' )
    '[ _ > dup _ ] keep ? ;

Using this to carry digits is pretty easy (using the 0 to 9 range):

: next-digit ( ch -- ? ch' )
    1 + CHAR: 9 CHAR: 0 carry ;

To carry letters, we need to make sure that the carry preserves the original case (uppercase or lowercase) of the letter:

: next-letter ( ch -- ? ch' )
    [ ch>lower 1 + CHAR: z CHAR: a carry ] [ LETTER? ] bi
    [ ch>upper ] when ;

And, finally, to generalize this to all characters, we check if it is a digit or a letter and dispatch to the proper function, or pass the character through if it is neither:

: next-char ( ch -- ? ch' )
    {
        { [ dup digit?  ] [ next-digit  ] }
        { [ dup Letter? ] [ next-letter ] }
        [ t swap ]
    } cond ;

This leaves the core of the algorithm, which starts at the end of the string, incrementing each character (continuing if the carry flag is true), and then handling the case where we need to carry the first character:

: (successor) ( str -- str' )
    dup length t [ over 0 > dupd and ] [
        drop 1 - dup pick [ next-char ] change-nth
    ] while nip [ dup first prefix ] when ;

: successor ( str -- str' )
    dup empty? [ (successor) ] unless ;

The code for this is on my Github, and compares favorably at 30 lines of code versus the original 50. The (successor) function uses a fair amount of stack shuffling, can you improve it?

Unique

2011-08-20T21:40:00.000-07:00

A few days ago, I noticed this example from the Racket website, for reporting "each unique line from stdin":

;; Report each unique line from stdin
(let ([saw (make-hash)])
  (for ([line (in-lines)])
    (unless (hash-ref saw line #f)
      (displayln line))
    (hash-set! saw line #t)))

We can implement the same functionality in Factor, reading each unique line from an input stream:

: unique-lines ( -- )
    lines members [ print ] each ;

The lines word acts on the "current input stream", so we can use a file reader as an input stream to print out all unique lines in a file:

: unique-file ( path -- )
    utf8 [ unique-lines ] with-file-reader ;

If we wanted to make this print and flush each unique line of input as it is read, we could have used the each-line word to implement it in a line-by-line fashion:

: unique-lines ( -- )
    HS{ } clone [
        dup pick in? [ drop ] [
            [ over adjoin ]
            [ print flush ] bi
        ] if
    ] each-line drop ;

Human Numbers

2011-08-14T19:21:00.000-07:00

I noticed a project on Github called slang.js. It includes a number of "string utility" functions that might be useful to Javascript developers. One that struck me as interesting was the humanize function for turning numbers into "humanized" strings such as "1st, 2nd, 3rd or 4th".

Note: this function is sometimes called "ordinalize" - for example, in the django.contrib.humanize module or the inflector python project.

We are going to translate this original version into Factor:

function humanize(number) {
    if(number % 100 >= 11 && number % 100 <= 13)
        return number + "th";

    switch(number % 10) {
        case 1: return number + "st";
        case 2: return number + "nd";
        case 3: return number + "rd";
    }

    return number + "th";
}

If we keep the same structure (although, without the advantage that early returns can provide), it looks like this:

: humanize ( n -- str )
    dup 100 mod 11 13 between? [ "th" ] [
        dup 10 mod {
            { 1 [ "st" ] }
            { 2 [ "nd" ] }
            { 3 [ "rd" ] }
            [ drop "th" ]
        } case
    ] if [ number>string ] [ append ] bi* ;

And, then build some tests to make sure it works.

[ "1st" ] [ 1 humanize ] unit-test
[ "2nd" ] [ 2 humanize ] unit-test
[ "3rd" ] [ 3 humanize ] unit-test
[ "4th" ] [ 4 humanize ] unit-test
[ "11th" ] [ 11 humanize ] unit-test
[ "12th" ] [ 12 humanize ] unit-test
[ "13th" ] [ 13 humanize ] unit-test
[ "21st" ] [ 21 humanize ] unit-test

Printf

2011-08-10T16:15:00.000-07:00

The venerable printf function is available in most languages. Used for "formatted printing", it allows you to convert most basic data types to a string. Several years ago, I contributed an implementation for Factor that currently lives in the formatting vocabulary. Using it looks a bit like this:

( scratchpad ) 12 "There are %d monkeys" printf
There are 12 monkeys

Implementation

One of the neat things about this version, is that the format string is parsed and code to format the arguments is generated at compile-time. Below, I've created a simplified version of printf to show how this works.

USING: io io.streams.string kernel macros make math math.parser
peg.ebnf present quotations sequences strings ;

We use the peg.ebnf vocabulary to parse the format string into a sequence of quotations (either strings or format instructions). Each quotation uses the make vocabulary to add these strings to a sequence (to be written out):

EBNF: parse-printf

fmt-%      = "%"   => [[ [ "%" ] ]]
fmt-c      = "c"   => [[ [ 1string ] ]]
fmt-s      = "s"   => [[ [ present ] ]]
fmt-d      = "d"   => [[ [ >integer number>string ] ]]
fmt-f      = "f"   => [[ [ >float number>string ] ]]
fmt-x      = "x"   => [[ [ >hex ] ]]
unknown    = (.)*  => [[ >string throw ]]

strings    = fmt-c|fmt-s
numbers    = fmt-d|fmt-f|fmt-x

formats    = "%"~ (strings|numbers|fmt-%|unknown)

plain-text = (!("%").)+
                   => [[ >string 1quotation ]]

text       = (formats|plain-text)*
                   => [[ [ \ , suffix ] map ]]

;EBNF

You can see the EBNF output by trying it in the listener:

( scratchpad ) "There are %d monkeys" parse-printf .
V{
    [ "There are " , ]
    [ >integer number>string , ]
    [ " monkeys" , ]
}

The "printf" macro takes the parsed output, reverses it (so the elements to be formatted can be passed on the stack in their natural order), applies each format quotation to the elements on the stack, and then writes them back in the original order.

MACRO: printf ( format-string -- )
    parse-printf reverse  [ ] concat-as [
        { } make reverse [ write ] each
    ] curry ;

You can use expand-macros to see the code the macro generates:

( scratchpad ) [ "There are %d monkeys" printf ] expand-macros .
[
    [ " monkeys" , >integer number>string , "There are " , ]
    { } make reverse [ write ] each
]

Implementing sprintf is easy using string streams to capture the output into a string object:

: sprintf ( format-string -- result )
    [ printf ] with-string-writer ; inline

Tests

We can write some unit tests to show that it works:

[ "" ] [ "" sprintf ] unit-test
[ "asdf" ] [ "asdf" sprintf ] unit-test
[ "10" ] [ 10 "%d" sprintf ] unit-test
[ "-10" ] [ -10 "%d" sprintf ] unit-test
[ "ff" ] [ HEX: ff "%x" sprintf ] unit-test
[ "Hello, World!" ] [ "Hello, World!" "%s" sprintf ] unit-test
[ "printf test" ] [ "printf test" sprintf ] unit-test
[ "char a = 'a'" ] [ CHAR: a "char %c = 'a'" sprintf ] unit-test
[ "0 message(s)" ] [ 0 "message" "%d %s(s)" sprintf ] unit-test
[ "10%" ] [ 10 "%d%%" sprintf ] unit-test
[ "[monkey]" ] [ "monkey" "[%s]" sprintf ] unit-test

This implementation doesn't support various format parameters such as width, alignment, padding characters, uppercase/lowercase, decimal digits, or scientific notation. Nor does it support formatting sequences and assocs, like the official version. However, adding those features is straightforward once you understand the basic mechanics.

The code for this is on my Github.

FizzBuzz

2011-08-06T08:36:00.000-07:00

The "new classic" programming test seems to be the FizzBuzz problem. I think it was first proposed in a blog post from 2007.

Now that it has garnered so much awareness (even videos on YouTube!), it's probably not a good interview question anymore. However, now that implementations have been written in many languages, it can be used to learn and compare the syntax of new languages.

Implementation

We can see how it works in Python:

>>> for i in range(1,101):
        if not i % 15:
            print "FizzBuzz"
        elif not i % 3:
            print "Fizz"
        elif not i % 5:
            print "Buzz"
        else:
            print i

A similar version in Clojure:

=>(defn multiple? [n div]
    (= 0 (mod n div)))

=>(doseq [i (range 1 101)]
     (cond (and (multiple? i 3)(multiple? i 5))
             (println "FizzBuzz")
           (multiple? i 3)
             (println "Fizz")
           (multiple? i 5)
             (println "Buzz")
       :else (println i)))

And, finally, a version in Factor:

( scratchpad ) 100 [1,b] [
                   {
                       { [ dup 15 divisor? ] [ drop "FizzBuzz" ] }
                       { [ dup 3  divisor? ] [ drop "Fizz"     ] }
                       { [ dup 5  divisor? ] [ drop "Buzz"     ] }
                       [ present ]
                   } cond print
               ] each

Improvements

Let's see if we can improve the Factor version a bit. First, we can "factor out" the FizzBuzz logic into its own function (showing how it would look if you were to code this directly into the listener):

( scratchpad ) : fizzbuzz ( n -- )
                   {
                       { [ dup 15 divisor? ] [ drop "FizzBuzz" ] }
                       { [ dup 3  divisor? ] [ drop "Fizz"     ] }
                       { [ dup 5  divisor? ] [ drop "Buzz"     ] }
                       [ present ]
                   } cond print ;

( scratchpad ) 100 [1,b] [ fizzbuzz ] each

To avoid all the dup and drop words, we could build a variation of cond that acts a bit like a case. The "cond-case" word was suggested on the Factor mailing list, and this is one variant of it:

MACRO: cond-case ( assoc -- )
    [
        dup callable? not [
            [ first [ dup ] prepose ]
            [ second [ drop ] prepose ] bi 2array
        ] when
    ] map [ cond ] curry ;

Using cond-case, we can improve the original version:

: fizzbuzz ( n -- )
    {
        { [ 15 divisor? ] [ "FizzBuzz" ] }
        { [ 3  divisor? ] [ "Fizz"     ] }
        { [ 5  divisor? ] [ "Buzz"     ] }
        [ present ]
    } cond-case print ;

If we realize that the check for divisible by 15 is the same as checking for divisible by 3 and divisible by 5, we can implement it slightly differently, without a cond or case:

: fizz ( n -- str/f )
    3 divisor? "Fizz" and ;

: buzz ( n -- str/f )
    5 divisor? "Buzz" and ;

: fizzbuzz ( n -- )
    dup [ fizz ] [ buzz ] bi "" append-as
    [ present ] [ nip ] if-empty print ;

Is it better? Can you think of any way to make it simpler? Perhaps by using or inventing some higher-level concepts like we did with cond-case?

Robohash

2011-07-29T14:56:00.000-07:00

A few days ago, I read about Robohash, a website for creating unique images (of robots) from any text. The author was thinking of using it for icons on a forum, but there are probably other use-cases for this. For example, as a variation of the color password hash to help users avoid typos in their passwords or, perhaps, as a visual representation of a user-submitted "secret code".

USING: images.http kernel sequences urls urls.encoding ;

First, we need to create URLs of the form http://robohash.org/YOUR_TEXT, as instructed:

: robohash-url ( str -- url )
    url-encode "http://robohash.org/" prepend >url ;

Next, we would like to support the different "image sets" that Robohash supports.

: (robohash) ( str type -- image )
    [ robohash-url ] [ "set" set-query-param ] bi*
    load-http-image ;

Using this, we can create image loaders for each set (currently three sets: "set1", "set2", and "set3"):

: robohash1 ( str -- image ) "set1" (robohash) ;

: robohash2 ( str -- image ) "set2" (robohash) ;

: robohash3 ( str -- image ) "set3" (robohash) ;

You can try it out and see that it works:

Robohash also supports custom backgrounds, changing image sizes, and varying image formats (e.g., JPG or BMP). Adding support for that is an exercise to the reader.

The code for this is on my Github.

Majority Vote

2011-07-23T13:58:00.000-07:00

A Linear Time Majority Vote Algorithm was invented in 1980 by Bob Boyer and J Strother Moore (inventors of the popular Boyer-Moore string search algorithm). Not seeing this available in Factor, I thought to contribute one.

Note: this is also called the "Moore’s Voting Algorithm".

The algorithm simply looks at each element of the sequence:

Keep a candidate element and a counter (initially unknown and zero, respectively).

As we move across the sequence, look at each element:

If the counter is 0: the element is the candidate and the counter is 1.
If the counter is not 0: increment if the element is the candidate, decrement if not.

When we are done, the candidate is the majority element, if there is a majority.

Using this specification, we can implement the algorithm:

: majority ( seq -- elt/f )
    [ f 0 ] dip [
        over zero? [ 2nip 1 ] [ 
            pick = [ 1 + ] [ 1 - ] if
        ] if
    ] each zero? [ drop f ] when ;

A few simple tests show that this is working:

[ f ] [ { } majority ] unit-test
[ f ] [ { 1 2 } majority ] unit-test
[ 1 ] [ { 1 1 2 } majority ] unit-test
[ f ] [ { 1 1 2 2 } majority ] unit-test
[ 2 ] [ { 1 1 2 2 2 } majority ] unit-test

This is perhaps not quite idiomatic Factor, can you improve it?

One-Liners

2011-07-19T14:05:00.000-07:00

Inspired by a blog post about "one-liners" in Clojure, I thought I'd demonstrate a few small pieces of Factor code doing some similar things:

Using the map word, we can apply a "doubling" quotation to each element.

( scratchpad ) { 4 8 15 16 23 42 } [ 2 * ] map .
{ 8 16 30 32 46 84 }

We can easily calculate the sum of a sequence (here the numbers 1 through 1000):

( scratchpad ) 1000 [1,b] sum .
500500

We check if any of a list of words are within a string:

( scratchpad ) { "factor" "concatenative" "stack-based" }
               [ "factor is awesome" subseq? ] any?

You can easily read the file-contents, or file-lines, with a specified encoding (e.g., UTF-8):

( scratchpad ) "/path/to/file.txt" utf8 file-contents

Sing the four verses to the "Happy Birthday" song:

( scratchpad ) 4 [1,b] [
                   "Happy Birthday " write
                   3 = "dear NAME" "to You" ? print
               ] each
Happy Birthday to You
Happy Birthday to You
Happy Birthday dear NAME
Happy Birthday to You

Use filter (or even partition) with some selection criteria:

( scratchpad ) { 49 58 76 82 88 90 } [ 60 > ] filter .
{ 76 82 88 90 }

Use the http.client vocabulary to access a web service, and then the xml vocabulary to parse the result from a string. You could use the json.reader vocabulary to parse JSON responses.

( scratchpad ) "http://search.twitter.com/search.atom?q=factor"
               http-get nip string>xml

Check the HTTP headers to find the version of a server used by a web server:

( scratchpad ) "http://apple.com" http-get drop
               header>> "server" swap at .
"Apache/2.2.3 (Oracle)"

Use infimum and supremum to find the minimum and maximum, respectively, of a list (alternatively, you could use my maximum/minimum functions):

( scratchpad ) { 14 36 -7 46 98 } infimum .
-7

( scratchpad ) { 14 36 -7 46 98 } supremum .
98

Parse a string into groups of two characters, then interpret those as hex values of characters, mapping the output as a string:

( scratchpad ) "474e552773204e6f7420556e6978"
               2 <groups> [ 16 base> ] "" map-as .
"GNU's Not Unix"

Use concurrency.combinators to perform certain tasks in parallel with futures:

( scratchpad ) { 1 0 -1 } [ 2 + ] parallel-map .
{ 3 2 1 }

Detecting Plagiarism

2011-07-15T09:56:00.000-07:00

About a month ago, Tom Moertel wrote a simple plagiarism detector in Haskell. I wanted to replicate his functionality using Factor, to contrast the two solutions.

The strategy in this plagiarism detector is fairly simple: calculate "long enough" n-grams that should be fairly unique and see if they are present in a particular piece of "suspect text", converting the common pieces into UPPERCASE so that we can visually see what might be plagiarized.

USING: command-line grouping io io.encodings.utf8 io.files
kernel math math.parser math.ranges namespaces regexp sequences
sets splitting unicode.case unicode.categories unicode.data ;

IN: plagiarism

We can split text (using the grouping vocabulary) into consecutive groups of "n" words:

: n-grams ( str n -- seq )
    [ [ blank? ] split-when harvest ] [ <clumps> ] bi* ;

Given a piece of text suspected to be plagiarized and some sources to compare against, we can compute the common n-grams between the two pieces of text:

: common-n-grams ( suspect sources n -- n-grams )
    [ n-grams ] curry dup [ map concat ] curry bi* intersect ;

For each common n-gram found, we use a regular expression to find the matching part of the suspect text. The regular expression we will use, looks something like a space or start of line followed by our n-gram and ending with a space or end of line, allowing varying whitespace between words, being case insensitive, and ignoring non-letters within a word:

: n-gram>regexp ( seq -- regexp )
    [ [ Letter? not ] split-when "[\\W\\S]" join ] map
    "\\s+" join "(\\s|^)" "(\\s|$)" surround
    "i" <optioned-regexp> ;

The sequences vocabulary contains a change-nth word to modify a particular element in a sequence. We can create a word to modify several elements easily:

: change-nths ( indices seq quot: ( elt -- elt' ) -- )
    [ change-nth ] 2curry each ; inline

Using change-nths and the "n-gram regexp", we can ch>upper each matching portion of text:

: upper-matches ( str regexp -- )
    [ [ [a,b) ] dip [ ch>upper ] change-nths ] each-match ;

Using these building blocks, we can build a simple plagiarism detector:

Compute the common n-grams between suspect and source texts
Create a regular expression for each common n-gram
For each match, change the matching characters to uppercase

: detect-plagiarism ( suspect sources n -- suspect' )
    [ dupd ] dip common-n-grams [
        dupd n-gram>regexp upper-matches
    ] each ;

A "main method" enables this program to run from the command line:

: run-plagiarism ( -- )
    command-line get dup length 3 < [
        drop "USAGE: plagiarism N suspect.txt source.txt..." print
    ] [
        [ rest [ utf8 file-contents ] map unclip swap ]
        [ first string>number ] bi detect-plagiarism print
    ] if ;

MAIN: run-plagiarism

You can see it work by trying to find common 4-grams on some simple text (in this case, I added the word "really"):

( scratchpad ) "this is a really long piece of text"
               { "this is a long piece of text" }
               4 detect-plagiarism print
this is a really LONG PIECE OF TEXT

It's fast enough for small examples, but not that fast for complete novels, particularly when run on texts with many common n-grams. One idea for improving the speed might be to examine the common-n-grams algorithm to return sequences of "n or more". This way, if the text contains a common 7-gram, and you are looking at common 4-grams, then it would have one entry instead of three.

The code for this is on my Github.

Concatenative Thinking

2011-07-12T20:57:00.000-07:00

I've written about the conciseness of Factor before. Yesterday, I noticed a link to a functional programming tutorial called "Functional Thinking" that was posted two months ago.

The tutorial develops a program for classifying numbers based on the sum of its factors into perfect, abundant, or deficient numbers. The program goes through three improvements, ending up at this "best" solution in Java (using the Functional Java library):

public class FNumberClassifier {

    public boolean isFactor(int number, int potential_factor) {
        return number % potential_factor == 0;
    }

    public List<Integer> factors(final int number) {
        return range(1, number+1).filter(new F<Integer, Boolean>() {
            public Boolean f(final Integer i) {
                return number % i == 0;
            }
        });
    }

    public int sum(List<Integer> factors) {
        return factors.foldLeft(fj.function.Integers.add, 0);
    }

    public boolean isPerfect(int number) {
        return sum(factors(number)) - number == number;
    }

    public boolean isAbundant(int number) {
        return sum(factors(number)) - number > number;
    }

    public boolean isDeficient(int number) {
        return sum(factors(number)) - number < number;
    }
}

While the proffered solution is much (much) better than the original "imperative" solution, I thought I would show what it could look like in Factor:

: factor? ( m n -- ? )
    mod zero? ;

: factors ( n -- seq )
    dup [1,b] [ factor? ] with filter ;

: perfect? ( n -- ? )
    [ factors sum ] [ - ] [ = ] tri ;

: abundant? ( n -- ? )
    [ factors sum ] [ - ] [ > ] tri ;

: deficient? ( n -- ? )
    [ factors sum ] [ - ] [ < ] tri ;

What do you think?

Substrings

2011-07-10T11:18:00.000-07:00

One year ago, I wrote about some new combinatoric functions that I wrote. I had a recent need for a couple of "substring" functions. Since I couldn't find them in Factor's standard library, I thought I would contribute these:

all-subseqs

Our first word takes a sequence, and then returns all (consecutive) subsequences that can be found. In Factor, the grouping vocabulary provides a clumping feature that splits a sequence into overlapping, fixed-length, subsequences. We can use this to find clumps of every possible length to solve this problem:

USING: grouping kernel math.ranges sequences ;

: all-subseqs ( seq -- seqs )
    dup length [1,b] [ <clumps> ] with map concat ;

You can see how this works:

( scratchpad ) "abcd" all-subseqs .
{ "a" "b" "c" "d" "ab" "bc" "cd" "abc" "bcd" "abcd" }

Note: we specifically don't include the "empty" string in the results.

longest-subseq

Several algorithms and implementations can be found for the longest common substring problem. Basically, we want a word that returns the longest (consecutive) substring that is common between two strings.

Using locals, I translated the Python solution:

USING: arrays kernel locals math math.ranges sequences ;

:: longest-subseq ( seq1 seq2 -- subseq )
    seq1 length :> len1
    seq2 length :> len2
    0 :> n!
    0 :> end!
    len1 1 + [ len2 1 + 0 <array> ] replicate :> table
    len1 [1,b] [| x |
        len2 [1,b] [| y |
            x 1 - seq1 nth
            y 1 - seq2 nth = [
                y 1 - x 1 - table nth nth 1 + :> len
                len y x table nth set-nth
                len n > [ len n! x end! ] when
            ] [ 0 y x table nth set-nth ] if
        ] each
    ] each end n - end seq1 subseq ;

Below, you can see how it works:

( scratchpad ) "abc" "def" longest-subseq .
""

( scratchpad ) "abcd" "abcde" longest-subseq .
"abcd"

Note: don't confuse this with the longest common subsequence problem (see substring vs. subsequence for more details), which is implemented in Factor by the lcs vocabulary.

99 Bottles

2011-07-07T09:04:00.000-07:00

The 99 Bottles Of Beer project has an entry for Factor. Unfortunately, it's for version 0.83 (latest released version is 0.94) and some minor changes have come into the language since then. Below, I contribute an updated version:

USING: formatting io kernel math math.ranges sequences ;

: verse ( n -- )
    dup "%d bottles of beer on the wall, " printf
    dup "%d bottles of beer.\n" printf
    "Take one down and pass it around, " write
    1 - "%d bottles of beer on the wall.\n" printf ;

: verse-1 ( -- )
    "1 bottle of beer on the wall, " write
    "1 bottle of beer." print
    "Take one down and pass it around, " write
    "no more bottles of beer on the wall." print ;

: verse-0 ( -- )
    "No more bottles of beer on the wall, " write
    "no more bottles of beer." print
    "Go to the store and buy some more, " write
    "99 bottles of beer on the wall." print ;

: 99bottles ( -- )
    99 2 [a,b] [ verse ] each verse-1 verse-0 ;

Shorter?

We can shorten this a bit by taking a few poetic liberties with the song. While doing that, we can make it flexible to allow any (positive) number of bottles:

USING: formatting io kernel math math.ranges sequences ;

: verse ( n -- )
    dup "%d bottles of beer on the wall, " printf
    dup "%d bottles of beer.\n" printf
    "Take one down and pass it around, " write
    1 - "%d bottles of beer on the wall.\n" printf ;

: last-verse ( -- )
    "Go to the store and buy some more, " write
    "no more bottles of beer on the wall!" print ;

: bottles ( n -- )
    1 [a,b] [ verse ] each last-verse ;

This solution is similar to the one posted on the Rosetta Code project.

Longer!

You might notice that a lot of the text is duplicative, so perhaps we can improve this solution by factoring out parts of the text into small and reusable functions.

USING: combinators formatting io kernel math sequences ;

: #bottles ( n -- str )
    {
        { 1 [ "1 bottle" ] }
        { 0 [ "no more bottles" ] }
        [ "%d bottles" sprintf ]
    } case " of beer" append ;

: on-the-wall ( n -- )
    #bottles dup "%s on the wall, %s.\n" printf ;

: take-one-down ( n -- )
    "Take one down and pass it around, " write
    #bottles "%s on the wall.\n" printf ;

: take-bottles ( n -- )
    [ dup zero? ] [
        [ on-the-wall ] [ 1 - dup take-one-down ] bi
    ] until on-the-wall ;

: go-to-store ( n -- )
    "Go to the store and buy some more, " write
    #bottles "%s on the wall.\n" printf ;

: bottles ( n -- )
    [ take-bottles ] [ go-to-store ] bi ;

It's a bit longer than the original and, in several ways, not as easy to understand. If we wanted to reuse this functionality elsewhere, it's a clear win. But, if we want to simply generate the "bottles song", perhaps the first or second way is better.

Extra Credit

For fun, I thought we could use our computer to sing to us (if you're using Mac OS X):

( scratchpad ) [ 99bottles ] with-string-writer
               "say \"%s\"" sprintf try-process

The code for this is on my Github.

Fourth of July

2011-07-04T11:25:00.000-07:00

Today is Independence Day in the United States. Several lists of fantastic facts are being shared, including that today is the "biggest beer-selling holiday of the year". However, while not as fantastic, here are a few fun facts about today that can be derived using Factor.

Using the calendar vocabulary, we can create a timestamp object for today's date:

( scratchpad ) 2011 7 4 <date> .
T{ timestamp
    { year 2011 }
    { month 7 }
    { day 4 }
    { gmt-offset T{ duration { hour -7 } } }
}

We can see that today is the 185^th day of the year:

( scratchpad ) 2011 7 4 <date> day-of-year .
185

Today is also the 27^th week of the year (using weeks starting on Sunday - there might be a different answer using week-of-year-monday:

( scratchpad ) 2011 7 4 <date> week-of-year-sunday .
27

This year, July 4^th falls on a Monday, but its a different day of the week each year. We can see which days of the week Independence Day falls on over the last few years:

( scratchpad ) 2011 2000 [a,b] [
                   dup 7 4 <date> day-name "%s: %s\n" printf
               ] each
2011: Monday
2010: Sunday
2009: Saturday
2008: Friday
2007: Wednesday
2006: Tuesday
2005: Monday
2004: Sunday
2003: Friday
2002: Thursday
2001: Wednesday
2000: Tuesday

And, finally, the most recent version of Factor (0.94) was released on September 18, 2010, which was 289 days ago.

( scratchpad ) 2011 7 4 <date> 2010 9 18 <date>
               time- duration>days .
289

TF-IDF

2011-06-29T15:38:00.000-07:00

A few days ago, someone implemented a consice TF-IDF ("term frequency - inverse document frequency") search engine in Scala. That was followed by a similarly concise version in Clojure. I thought to contribute a simple (hopefully also concise) implementation using Factor.

USING: accessors arrays assocs combinators.short-circuit fry
io.encodings.utf8 io.files kernel math math.functions
math.statistics memoize sequences sets sorting splitting
unicode.case unicode.categories ;

IN: tf-idf

Tokenize

Since our inputs are going to be text files, our program will need to:

Read the file into a string.
Split the string into words.
Eliminate common (or "stop") words.

Fist, let's build a word to split our text on any non-letter or non-number characters.

: split-words ( string -- words )
    [ { [ Letter? ] [ digit? ] } 1|| not ] split-when harvest ;

We load a list of "stop words" that are to be ignored. These are typically common occurring words such as "and, in, or, of, the, is".

MEMO: stopwords ( -- words )
    "vocab:tf-idf/stopwords.txt" utf8 file-lines fast-set ;

We can then tokenize a piece of text, removing all of the "stop words".

: tokenize ( string -- words )
    >lower split-words [ stopwords in? not ] filter ;

And, finally, we can create a word to tokenize a series of files into an assoc mapping path to words.

: tokenize-files ( paths -- assoc )
    [ dup utf8 file-contents tokenize ] H{ } map>assoc ;

Index

To implement our search engine, we need to build an index that maps each word to list of (path, count) pairs.

: index1 ( path words -- path index )
    histogram [ pick swap 2array ] assoc-map ;

: index-all ( assoc -- index )
    [ index1 ] assoc-map values assoc-merge ;

The tokenized files and our index will form the basis for a "database":

TUPLE: db docs index ;

: <db> ( paths -- db )
    tokenize-files dup index-all db boa ;

TF-IDF

The "inverse document frequency" is calculated by the log of the total number of documents divided by number of documents where a particular word appears.

: idf ( term db -- idf )
    [ nip docs>> ] [ index>> at ] 2bi [ assoc-size ] bi@ / log ;

Using this, we can create a "TF-IDF" scores by multiplying the number of times a term appears in each document by the previously calculated "inverse document frequency":

: tf-idf ( term db -- scores )
    [ index>> at ] [ idf ] 2bi '[ _ * ] assoc-map ;

Search

Our search engine is now just a matter of:

Splitting an input query into terms.
Calculating the "TF-IDF" score for each term.
Normalizing the scores across documents.
Sorting the scores from highest to lowest.

: scores ( query db -- scores )
    [ split-words ] dip '[ _ tf-idf ] map assoc-merge ;

: (normalize) ( path db -- value )
    [ docs>> at ] keep '[ _ idf 2 ^ ] map-sum sqrt ;

: normalize ( scores db -- scores' )
    '[ sum over _ (normalize) / ] assoc-map ;

: search ( query db -- scores )
    [ scores ] keep normalize sort-values reverse ;

Notes

The implementation above uses an assoc-merge utility word that performs a "union", for each key collecting a list of all values.

: (assoc-merge) ( assoc1 assoc2 -- assoc1 )
    over [ push-at ] with-assoc assoc-each ;

: assoc-merge ( seq -- merge )
    H{ } clone [ (assoc-merge) ] reduce ;

Also, searching for words that don't exist produces a "divide by zero" error. Making it more robust requires some changes to either catch and ignore that error or to "add 1" to the denominator of the "IDF" formula.

The code for this is on my Github.

Yahoo! Finance

2011-06-10T21:23:00.000-07:00

Many programmers work for publicly traded companies, and probably spend more time than they realize watching their (or their friends) company's stock prices. To make that easier, I wanted to implement a simple wrapper to retrieve prices from Yahoo! Finance.

Quotes

You can use a "quotes.csv" interface to retrieve current price information. The way it works is to perform an HTTP request to a specially formatted URL that looks like:

http://finance.yahoo.com/d/quotes.csv?s=SYMBOLS&f=FIELDS

In the URL, SYMBOLS is a list of symbols separated by "+" and FIELDS is a list of letters and numbers (from the following table) representing fields to be requested.

a Ask a2 Average Daily Volume a5 Ask Size
b Bid b2 Ask (Real-time) b3 Bid (Real-time)
b4 Book Value b6 Bid Size c Change & Percent Change
c1 Change c3 Commission c6 Change (Real-time)
c8 After Hours Change (Real-time) d Dividend/Share d1 Last Trade Date
d2 Trade Date e Earnings/Share e1 Error Indication (returned for symbol changed / invalid)
e7 EPS Estimate Current Year e8 EPS Estimate Next Year e9 EPS Estimate Next Quarter
f6 Float Shares g Day’s Low h Day’s High
j 52-week Low k 52-week High g1 Holdings Gain Percent
g3 Annualized Gain g4 Holdings Gain g5 Holdings Gain Percent (Real-time)
g6 Holdings Gain (Real-time) i More Info i5 Order Book (Real-time)
j1 Market Capitalization j3 Market Cap (Real-time) j4 EBITDA
j5 Change From 52-week Low j6 Percent Change From 52-week Low k1 Last Trade (Real-time) With Time
k2 Change Percent (Real-time) k3 Last Trade Size k4 Change From 52-week High
k5 Percent Change From 52-week High l Last Trade (With Time) l1 Last Trade (Price Only)
l2 High Limit l3 Low Limit m Day’s Range
m2 Day’s Range (Real-time) m3 50-day Moving Average m4 200-day Moving Average
m5 Change From 200-day Moving Average m6 Percent Change From 200-day Moving Average m7 Change From 50-day Moving Average
m8 Percent Change From 50-day Moving Average n Name n4 Notes
o Open p Previous Close p1 Price Paid
p2 Change in Percent p5 Price/Sales p6 Price/Book
q Ex-Dividend Date r P/E Ratio r1 Dividend Pay Date
r2 P/E Ratio (Real-time) r5 PEG Ratio r6 Price/EPS Estimate Current Year
r7 Price/EPS Estimate Next Year s Symbol s1 Shares Owned
s7 Short Ratio t1 Last Trade Time t6 Trade Links
t7 Ticker Trend t8 1 yr Target Price v Volume
v1 Holdings Value v7 Holdings Value (Real-time) w 52-week Range
w1 Day’s Value Change w4 Day’s Value Change (Real-time) x Stock Exchange
y Dividend Yield

a	Ask	a2	Average Daily Volume	a5	Ask Size
b	Bid	b2	Ask (Real-time)	b3	Bid (Real-time)
b4	Book Value	b6	Bid Size	c	Change & Percent Change
c1	Change	c3	Commission	c6	Change (Real-time)
c8	After Hours Change (Real-time)	d	Dividend/Share	d1	Last Trade Date
d2	Trade Date	e	Earnings/Share	e1	Error Indication (returned for symbol changed / invalid)
e7	EPS Estimate Current Year	e8	EPS Estimate Next Year	e9	EPS Estimate Next Quarter
f6	Float Shares	g	Day’s Low	h	Day’s High
j	52-week Low	k	52-week High	g1	Holdings Gain Percent
g3	Annualized Gain	g4	Holdings Gain	g5	Holdings Gain Percent (Real-time)
g6	Holdings Gain (Real-time)	i	More Info	i5	Order Book (Real-time)
j1	Market Capitalization	j3	Market Cap (Real-time)	j4	EBITDA
j5	Change From 52-week Low	j6	Percent Change From 52-week Low	k1	Last Trade (Real-time) With Time
k2	Change Percent (Real-time)	k3	Last Trade Size	k4	Change From 52-week High
k5	Percent Change From 52-week High	l	Last Trade (With Time)	l1	Last Trade (Price Only)
l2	High Limit	l3	Low Limit	m	Day’s Range
m2	Day’s Range (Real-time)	m3	50-day Moving Average	m4	200-day Moving Average
m5	Change From 200-day Moving Average	m6	Percent Change From 200-day Moving Average	m7	Change From 50-day Moving Average
m8	Percent Change From 50-day Moving Average	n	Name	n4	Notes
o	Open	p	Previous Close	p1	Price Paid
p2	Change in Percent	p5	Price/Sales	p6	Price/Book
q	Ex-Dividend Date	r	P/E Ratio	r1	Dividend Pay Date
r2	P/E Ratio (Real-time)	r5	PEG Ratio	r6	Price/EPS Estimate Current Year
r7	Price/EPS Estimate Next Year	s	Symbol	s1	Shares Owned
s7	Short Ratio	t1	Last Trade Time	t6	Trade Links
t7	Ticker Trend	t8	1 yr Target Price	v	Volume
v1	Holdings Value	v7	Holdings Value (Real-time)	w	52-week Range
w1	Day’s Value Change	w4	Day’s Value Change (Real-time)	x	Stock Exchange
y	Dividend Yield

Using this URL format, we can build a word that retrieves current quotes for a list of symbols:

: quotes ( symbols -- csv )
    "http://finance.yahoo.com/d/quotes.csv" >url
        swap "+" join "s" set-query-param
        "sbal1v" "f" set-query-param
    http-get nip >string string>csv
    { "Symbol" "Bid" "Ask" "Last" "Volume" } prefix ;

With the strings.table vocabulary, we can format the response as a table:

( scratchpad ) { "MSFT" "GOOG" "AAPL" } quotes
               format-table [ print ] each
Symbol Bid    Ask    Last    Volume
MSFT   23.64  23.69  23.705  49327104
GOOG   505.00 509.05 509.505 2440475
AAPL   N/A    334.80 325.90  15504200

Historical Prices

You can also retrieve historical prices using a "table.csv" interface. Similar to retrieving quotes, you make an HTTP request to a special URL:

http://ichart.finance.yahoo.com/table.csv?s=SYMBOL

In the URL, SYMBOL is the symbol that you are requesting prices for, and you can further limit the response using additional parameters:

Start date for historical prices:

a - Month number, starting with 0 for January.
b - Day number, eg, 1 for the first of the month.
c - Year.

End date for historical prices (default is the most current available closing price):

d - Month number, starting with 0 for January.
e - Day number, eg, 1 for the first of the month.
f - Year.

And finally, the frequency of historical prices:

g - Possible values are 'd' for daily (the default), 'w' for weekly, and 'm' for monthly.

With this knowledge, we can build a word to retrieve historical prices from January 1, 2009 until the current day.

: historical-prices ( symbol -- csv )
    "http://ichart.finance.yahoo.com/table.csv" >url
       swap "s" set-query-param
       "0" "a" set-query-param
       "1" "b" set-query-param
       "2009" "c" set-query-param
    http-get nip string>csv ;

To use it, and demonstrate the impact that AAPL has had over the last few years, we can chart the daily closing prices (remembering to reverse the order of the prices, oldest to newest):

The code for this is on my Github.

Fibonacci Wars

2011-05-17T11:53:00.000-07:00

Inspired by a recent article about the "worst algorithm in the world" for calculating Fibonacci numbers using Python, I wanted to show a few implementations in Factor.

Recursive

Most people should be familiar with the simple definition for calculating the Fibonacci numbers:

Some recursive implementations of this algorithm suffer from very slow performance due to the nature of hugely recursive functions, making them unsuitable for larger Fibonacci numbers. Thankfully, it is easy to implement caching using the memoize vocabulary:

MEMO: slow-fib ( m -- n )
    dup 0 >= [ throw ] unless
    dup 2 >= [
        [ 2 - slow-fib ] [ 1 - slow-fib ] bi +
    ] when ;

Iterative

A better way would be to implement an iterative solution, that simply keeps the current and previous Fibonacci number on the stack, adding them the specified number of times:

: okay-fib ( m -- n )
    dup 0 >= [ throw ] unless
    [ 0 1 ] dip [ [ + ] [ drop ] 2bi ] times drop ;

Magical

A much better way (introduced by the original article) suggests taking advantage of a matrix expression for the Fibonacci numbers:

Using this, we can implement a faster version in Factor (using locals to make it a bit more readable):

:: fast-fib ( m -- n )
    m 0 >= [ m throw ] unless
    m 2 >base [ CHAR: 1 = ] { } map-as :> bits
    1 :> a! 0 :> b! 1 :> c!
    bits [
        [
            a c + b *
            b sq c sq +
        ] [
            a sq b sq +
            a c + b *
        ] if b! a! a b + c!
    ] each b ;

Performance

Some simple performance numbers show how much faster the "magical" version is, particularly for calculating large Fibonacci numbers (such as the the one-millionth number in the sequence).

10,000 100,000 1,000,000
slow-fib 0.0097 -- --
okay-fib 0.0053 0.2560 25.9608
fast-fib 0.0001 0.0076 0.4851

	10,000	100,000	1,000,000
`slow-fib`	0.0097	--	--
`okay-fib`	0.0053	0.2560	25.9608
`fast-fib`	0.0001	0.0076	0.4851

It's worth pointing out that Factor is about as fast as Python 2.6 for the "magical" calculation. In Python 2.7 and later, certain improvements were made to their large number support, resulting in Python being about 3x faster.

However, if you want real performance, you can use C and the GNU Multiple Precision Arithmetic Library to implement the iterative algorithm (about 3 times faster than Factor), the magical algorithm (about 28 times faster than Factor), or use the builtin mpz_fib_ui function (about 44 times faster than Factor).

The code for this (as well as several version in C) are on my Github.

Google Search

2011-05-15T10:15:00.000-07:00

A couple months ago, I implemented wrappers for the Google Charts and Google Translate API's. Today, I'd like to implement a wrapper for Google Search.

Search

First, we should build a word that, given a query, returns a URL to retrieve Google Search results (formatted as JSON):

: search-url ( query -- url )
    URL" http://ajax.googleapis.com/ajax/services/search/web"
        "1.0" "v" set-query-param
        swap "q" set-query-param
        "8" "rsz" set-query-param
        "0" "start" set-query-param ;

We can define a tuple class to hold the attributes every search result should have:

TUPLE: search-result cacheUrl GsearchResultClass visibleUrl
title content unescapedUrl url titleNoFormatting ;

Using some code to set attributes dynamically, we can perform a Google Search, and parse the results into a sequence of search-result objects.

: http-search ( query -- results )
    search-url http-get nip json>
    { "responseData" "results" } [ swap at ] each
    [ \ search-result from-slots ] map ;

Display

We can build some simple words that can be used to format the output of a search:

: write-heading ( str -- )
    H{ 
        { font-size 14 }
        { background COLOR: light-gray }
    } format nl ;

: write-title ( str -- )
    H{ 
        { foreground COLOR: blue }
    } format nl ;

: write-content ( str -- )
    60 wrap-string print ;

: write-url ( str -- )
    dup >url H{ 
        { font-name "monospace" }
        { foreground COLOR: dark-green }
    } [ write-object ] with-style nl ;

And then create a word to perform a search and display the results. If you are using my webbrowser vocabulary, you can open the URL's in a webbrowser directly from Factor.

: http-search. ( query -- )
    [ "Search results for '%s'" sprintf write-heading nl ]
    [ http-search ] bi [
        {
            [ titleNoFormatting>> write-title ]
            [ content>> write-content ]
            [ unescapedUrl>> write-url ]
        } cleave nl
    ] each ;

Try it out

If everything works correctly, you should be able to perform a search in the Listener (e.g., searching for "factor"):

Some things we might do to improve this:

add paging, to the next or previous page of search results
highlight in bold the searched words in the content
unescape the HTML entities in the content
build a lightweight GUI to render the results

The code for this is on my Github.

Open URL (in Listener)

2011-05-05T21:38:00.000-07:00

In January, I implemented a cross-platform open-url feature to allow opening URLs from Factor. One major problem was that I couldn't figure out how to make URLs "clickable" in the Listener.

Then, I learned that the ui.operations vocabulary allows us to add "capabilities" that get triggered when certain types are rendered in the Listener. It turns out to be pretty easy, actually:

[ url? ] \ open-url H{ } define-operation

Using that, you can right-click on URL objects, and choose to open them in your web browser:

I also made a small patch to add this support to URLs that are rendered in the help system or in the slides vocabulary.

Note: if you want this operation to be the "primary operation" triggered when the URL is left-clicked, you can add { +primary+ t } to the hashtable used in the operation's definition.

Reddit Stats

2011-05-01T19:49:00.000-07:00

I thought it would be fun to track the development of the Factor programming language using Reddit. Of course, to do this, I wanted to use Factor.

A few months ago, I implemented a Reddit "Top" program. We can use the code for that as a basis for showing, using Reddit scores, how the activity (or popularity?) of a couple Factor blogs have changed over the last few years:

Stories

We start by creating a story tuple that will hold all of the properties that Reddit returns for each posted link (including the score -- up votes minus down votes -- which we will be using).

TUPLE: story author clicked created created_utc domain downs
hidden id is_self levenshtein likes media media_embed name
num_comments over_18 permalink saved score selftext
selftext_html subreddit subreddit_id thumbnail title ups url ;

And a word to parse a "data" result into a story object:

: parse-story ( assoc -- obj )
    "data" swap at \ story from-slots ;

Paging

The Reddit API provides results as a series of "pages" (until all results are exhausted). This is pretty similar to how the website works, so it should be fairly easy to understand the mechanics. We will define a page object that holds the current URL, the results from the current page, and links to the pages before and after the current page:

TUPLE: page url results before after ;

We can then build a word to fetch the page (as a JSON response), parse it, and construct a page object:

: json-page ( url -- page )
    >url dup http-get nip json> "data" swap at {
        [ "children" swap at [ parse-story ] map ]
        [ "before" swap at [ f ] when-json-null ]
        [ "after" swap at [ f ] when-json-null ]
    } cleave \ page boa ;

An easy "paging" mechanism that, given a page of results, can return the next page:

: next-page ( page -- page' )
    [ url>> ] [ after>> "after" set-query-param ] bi json-page ;

And, using the make vocabulary, construct all the results into a sequence:

: all-pages ( page -- results )
    [
        [ [ results>> , ] [ dup after>> ] bi ]
        [ next-page ] while drop
    ] { } make concat ;

Domain Stats

We can retrieve all the results and produces a map of years that links were posted to a sum of the scores for each year's links:

: domain-stats ( domain -- stats )
    "http://api.reddit.com/domain/%s" sprintf json-page all-pages
    [ created>> 1000 * millis>timestamp year>> ] group-by
    [ [ score>> ] map-sum ] assoc-map ;

Finally, a word to display a chart of the scores across a given list of domains:

: domains. ( domains -- )
    H{ } clone [
        '[ domain-stats [ swap _ at+ ] assoc-each ] each
    ] keep >alist sort-keys <bar> 160 >>height chart. ;

The code for this is available on my Github.