John Benediktsson: 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.
John Benediktsson: 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.
John Benediktsson: 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.
John Benediktsson: 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.
John Benediktsson: 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
" | CASINO |" print
3dup " |%c |%c |%c | |\n" printf
" | [_] |" 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.
John Benediktsson: 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.
Chris Double: Pattern Matching Against Linear Objects in ATS
In a project I’m working on I’m using linear lists. This is the list_vt type in the ATS prelude. list_vt is similar to the list types in Lisp and functional programming languages except it is linear. The memory for the list is not managed by the garbage collector and the type system enforces the rule that only one reference to the linear object can exist. This sometimes requires a bit of extra effort when using pattern matching against the list_vt instances.
Pattern Matching
When pattern matching against linear objects you can do a destructive match or a non-destructive match. The former will destroy and free the memory allocated for the object automatically. The latter will not. Destructive matches are done by having the pattern match clause prefixed with a ~. For example, the following will print an integer list and destroy the list while it does it:
fun print_list (l: List_vt (int)): void =
case+ l of
| ~list_vt_nil () => printf("nil\n", @())
| ~list_vt_cons (x, xs) => (printf("cons %d\n", @(x)); print_list(xs))
fun test1 (): void = {
val a = list_vt_cons {int} (1, list_vt_nil)
val () = print_list (a)
}Things get complicated when doing non-destructive matches. The following won’t typecheck:
fun print_list2 (l: !List_vt (int)): void =
case+ l of
| list_vt_nil () => printf("nil\n", @())
| list_vt_cons (x, xs) => (printf("cons %d\n", @(x)); print_list(xs))
fun test2 (): void = {
val a = list_vt_cons {int} (1, list_vt_nil)
val () = print_list2 (a)
val () = list_vt_free (a)
}The problem with this example is that when the match is made we are effectively taking the linear object out of the variable l. This leaves l with a different type, but we’ve stated in the function signature for print_list2 that the type is not modified or consumed. We need a way of putting the linear object back into l once we’re done using the match. This primitive to do this is fold@ which I briefly introduced in my linear datatypes post. fold@ will change the type of l back to the original and prevent access to the pattern match variables. Usage looks like this:
fun print_list2 (l: !List_vt (int)): void =
case+ l of
| list_vt_nil () => (fold@ l; printf("nil\n", @()))
| list_vt_cons (x, !xs) => (printf("cons %d\n", @(x)); print_list2(!xs); fold@ l)
fun test2 (): void = {
val a = list_vt_cons {int} (1, list_vt_nil)
val () = print_list2 (a)
val () = list_vt_free (a)
}You’ll notice with this version that the match for list_vt_cons has changed the xs parameter to be !xs. The second argument in the cons constructor is a linear object. If the object itself is matched against xs then it is another example of aliasing the linear object. It is taken out of the l and needs to be put back. The way ATS handles this is to require pattern matching with a ! prefixed. This makes xs be a pointer to the object rather than the object itself. So in this example xs has the type ptr addr where addr is the address of the actual List_vt object. This is why the xs is prefixed by ! in the recursive call to print_list2. The ! means dereference the pointer, so the List_vt it is pointing to is passed as the argument to the recursive call.
In this way the linear object is never taken out, we only access it via its pointer. The fold@ call in this clause will change xs back to the List_vt object. The fold@ call is done after the usage of !xs. If it was done before then we wouldn’t have access to the view for xs to be able to derefence it. print_list2 is still tail recursive as the fold@ call is only used during typechecking and is erased afterwards.
Filtering a linear list
In my project I needed to filter a linear list. Unfortunately ATS doesn’t have a filter implementation in the standard prelude for linear lists (it does for persistent lists). My first attempt at writing a list_vt_filter looked like:
fun list_vt_filter (l: !List_vt (int), f: int -<> bool): List_vt (int) =
case+ l of
| list_vt_nil () => (fold@ l; list_vt_nil)
| list_vt_cons (x, !xs) when f (x) => let
val r = list_vt_cons (x, list_vt_filter (!xs, f))
in
fold@ l; r
end
| list_vt_cons (x, !xs) => let
val r = list_vt_filter (!xs, f)
in
fold@ l; r
endThis should look familiar since it’s very similar to the print_list2 code shown previously in the way it uses non-destructive matching and fold@. The function list_vt_filter takes a list_vt as an argument and a function to apply to each element in the list. That function returns true if the element should be included in the result list. Usage looks like:
val a = list_vt_cons (1, list_vt_cons (2, list_vt_cons (3, list_vt_cons (4, list_vt_nil ()))))
val b = list_vt_filter (a, lam (x) => x mod 2 = 0)
val () = list_vt_foreach_fun<int> (a, lam(x) =<> $effmask_all (printf("Value: %d\n", @(x))))
val () = list_vt_free (b)
val () = list_vt_free (a)One issue with this implementation is it is not tail recursive. It has stack growth proportional to the size of the result list.
Tail Recursive Filtering
In Lisp code I’d often build the result list tail recursively by passing an accumulator, with each new element in the result being prepended to the accumulator. This builds a list in the reverse order so before returning it the list would be reversed. The ATS code for this is:
fun list_vt_filter (l: !List_vt (int), f: int -<> bool): List_vt (int) = let
fun loop (l: !List_vt (int), accum: List_vt (int)):<cloptr1> List_vt (int) =
case+ l of
| list_vt_nil () => (fold@ l; accum)
| list_vt_cons (x, !xs) when f (x) => let
val r = loop (!xs, list_vt_cons (x, accum))
in
(fold@ l; r)
end
| list_vt_cons (x, !xs) => let
val r = loop (!xs, accum)
in
(fold@ l; r)
end
in
list_vt_reverse (loop (l, list_vt_nil))
endThe cloptr1 function annotation marks the inner function as being a closure where the memory for the closure’s environment is managed by the compiler using malloc and free instead of the garbage collector (which is what cloref1 would signify). See my post on closures in ATS for more about the different closure and function types used by ATS.
Unfortunately the requirement to use fold@ after we’ve finished with using the pattern matched variables makes the code slightly more verbose as we need to do the tail recursion, obtaining the result, then do the fold@ and return the result. Remember that the fold@ is erased at type checking type which is how this code remains tail recursive even though the code structure makes it look like it isn’t.
One downside to this approach is we iterate over the list twice. Once to build the result, and once over the result to reverse it.
Single Pass Tail Recursive Filtering
The creation of the result list can be done in a single pass if we could create a cons with no second argument, and fill in that argument later when we have a result to store there that passes filtering. ATS allows construction of datatypes with a ‘hole’ that can be filled in later. The ‘hole’ is an unintialized type and we get a pointer to it. An example of doing this is:
var x = list_vt_cons {int} {0} (1, ?)This creates a list_vt_cons with the data set to 1 but no second parameter. Instead of that parameter being of type List_vt (int) it is of type List_vt (int)?, the ? signifying it is uninitialized. For this example we have to pass the universal type parameters explicitly (the {int} {0}) as the ATS type inference algorithm can’t compute them.
To get a pointer to the ‘hole’ we have to pattern match:
val+ list_vt_cons (_, !xs) = x
val () = !xs := list_vt_nil
val () = fold@ xIn this example the xs is a pointer, pointing to the List_vt (int)?. It assigns a list_vt_nil to this, making the tail of the cons a list_vt_nil. Just like in our previous pattern matching examples using case, the code has to do a fold@ to change the type of x back to that containing a linear object once we’ve finished using xs.
Now that we can get pointers to the tail of the list we can implement a single pass tail recursive filter function:
fun list_vt_filter (l: !List_vt (int), f: int -<> bool): List_vt (int) = let
fun loop (l: !List_vt (int), res: &List_vt (int)? >> List_vt (int)):<cloptr1> void =
case+ l of
| list_vt_nil () => (fold@ l; (res := list_vt_nil))
| list_vt_cons (x, !xs) when f (x) => let
val () = res := list_vt_cons {int} {0} (x, ?)
val+ list_vt_cons (_, !p_xs) = res
in
loop (!xs, !p_xs); fold@ l; fold@ res
end
| list_vt_cons (x, !xs) => (loop (!xs, res); fold@ l)
var res: List_vt (int)?
val () = loop (l, res)
in
res
endThe loop function here no longer turns a result. Instead the result is passed via a reference (the & signifies ‘by reference’). When there is something that needs to be stored in the list, a cons is created with a hole in the tail position. This cons is stored in the result we are passing by reference and we tail recursively call with the hole as the new result. ATS converts this to nice C code that is a simple loop rather than recursive function calls.
Miscellaneous
The code examples in this post use List_vt (a). This is actually a typedef for list_vt (a,n) where a is the type and n is the length of the list. The typedef allows shorter examples without needing to specify the sorts for the list length. Using the full type though has the advantage of being able to specifiy a bit more type safety. For example, the original filter function would be declared as:
fun list_vt_filter {n:nat} (l: !list_vt (int,n), f: int -<> bool): [r:nat | r <= n] list_vt (int, r)This defines the type of the result as having a length equal to or less than that of the original list. This helps prevent errors in the implementation of the filter - it can’t accidentally leave extra items in the list. I cover this type of thing in my post on dependent types.
Another addition to safety that adding the extra sorts can provide is the ability to check that the function terminates. This can be done by adding a termination metric to the function definition:
fun list_vt_filter {n:nat} .<n>. (l: !list_vt (int,n), f: int -<> bool): [r:nat | r <= n] list_vt (int, r)The compiler checks that n is decreasing on each recursive call. If this fails to happen the recursive calls may not terminate and it becomes a compile error. This is discussed in the Termination-Checking for Recursive Functions section of the Introduction to Programming in ATS book.
A description of how fold@ works is in the ATS/Anairats User’s Guide PDF. It’s in the ‘Dataviewtypes’ section of the ‘Programming with Linear Types’ chapter and is referred to as folding and unfolding a linear type.
It’s the usage of linear types and dealing with their restrictions that makes my examples a bit more complex. If you use ATS mainly with non-linear types and link with the garbage collector then it becomes very much like using any other functional programming language, but with additional features in the type system. My interest has been around avoiding using a garbage collector and having the compiler give errors when memory is not allocated or free’d correctly. Don’t be put off from using ATS by these complex examples if you’re fine with using garbage collection and non-linear datatypes. You might never need to deal with the cases that bring in the extra complexity.
Samuel Tardieu: Accessing serial ports the easy way
Every once in a while, I see people having a hard time accessing a RS232 or USB serial port from Java. There exist several solutions to do this in Java:
The Java Communications 3.0 API looks awfully old and unmaintained. It is available for Solaris SPARC, Solaris x86, and Linux x86.
RXTX is a mix between Java code and C code accessed through the Java native interface. It is hosted on a CVS server and it looks like the 2.2 release will never go out since it got stuck on version 2.2pre2 released in 2009. The last stable version is 2.1.7 from 2006.
PureJavaComm is a drop-in replacement for those two libraries, written in Java and using JNA to interface with the system. It is simpler to setup than RXTX, is hosted on GitHub and is actively maintained.
However, there exist at least one other solution which does not require the use of any external library. This is what I chose to interface a Scala program with a XBee Pro module through a serial interface to interact with my students devices. I also use it to interface the Factor programming language with the same XBee module.
Every language has a well-defined and well-maintained sockets library, right? So why not simply use socat, a multipurpose relay which is able to bridge many protocols and interfaces such as, in our case, TCP and a serial port?
I launch socat as
% socat TCP-LISTEN:4161,fork,reuseaddr FILE:/dev/ttyUSB0,b57600,raw
and what I immediately get is a TCP server listening onto port 4161 and ready to relay any incoming connection to the /dev/ttyUSB0 serial port with a 57600 baud rate. And not only do I have no more concern about accessing the serial port properly, but also I can access a port located on a remote computer as easily by launching socat there instead of locally.
But what if I want to spy on the TCP/serial relay to see that I send the right codes to the XBee module? socat offers you a choice of command-line options to dump the data in various formats.
What does the Scala interface look like? I have a XBee abstract class lacking an InputStream to receive the input from the XBee module and an OutputStream to send the output to it. This class is extended into a concrete class using simply:
import java.net.Socket
class TCPXBee(host: String, port: Int) extends XBee {
private val socket: Socket = new Socket(host, port)
override protected val inStream = socket.getInputStream
override protected val outStream = socket.getOutputStream
init()
}
socat makes my life easy. It is probably already packaged for your operating system, go and get it! Oh, and did I mention that it works with IPv6 too?
(Tags: Factor, Free Software, Java, IPv6, Scala)
Blogroll
- Chris Double
- Daniel Ehrenberg
- Doug Coleman
- Fred Alger
- Jeremy Hughes
- Joe Groff
- John Benediktsson
- Phil Dawes
- Samuel Tardieu
- Slava Pestov
planet-factor is an Atom/RSS aggregator that collects the contents of Factor-related blogs. It is inspired by Planet Lisp.
