Colored Timestamps

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

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

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.

The code for this is on my Github.

Picomath

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

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

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

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 ;