[ planet-factor ]

John Benediktsson: Bowling Scores

Today we are going to explore building a bowling score calculator using Factor. In particular, we will be scoring ten-pin bowling.

There are a lot of ways to "golf" this, including this short version in F#, but we will build this in several steps through transformations of the input. The test input is a string representation of the hits, misses, spares, and strikes. The output will be a number which is your total score. We will assume valid inputs and not do much error-checking.

A sample game might look like this:

12X4--3-69/-98/8-8-

Our first transformation is to convert each character to a number of pins that have been knocked down for each ball. Strikes are denoted with X, spares with /, misses with -, and normal hits with a number.

: pin ( last ch -- pin )
{
{ CHAR: X [ 10 ] }
{ CHAR: / [ 10 over - ] }
{ CHAR: - [ 0 ] }
[ CHAR: 0 - ]
} case nip ;

We use this to convert the entire string into a series of pins knocked down for each ball.

: pins ( str -- pins )
f swap [ pin dup ] { } map-as nip ;

A single frame will be either one ball, if a strike, or two balls. We are going to use cut-slice instead of cut because it will be helpful later.

: frame ( pins -- rest frame )
dup first 10 = 1 2 ? short cut-slice swap ;

A game is 9 "normal" frames and then a last frame that could have up to three balls in it.

: frames ( pins -- frames )
9 [ frame ] replicate swap suffix ;

Some frames will trigger a bonus. Strikes add the value of the next two balls. Spares add the value of the next ball. We build this by "un-slicing" the frame and calling sum on the next n balls.

: bonus ( frame n -- bonus )
[ [ seq>> ] [ to>> ] bi tail ] dip head sum ;

We can score the frames by checking for frames where all ten pins are knocked down (either spares or strikes) and adding their bonus.

: scores ( frames -- scores )
[
dup [ sum ] [ length ] bi over 10 = [
3 swap - swapd bonus +
] [
drop nip
] if
] map ;

We can solve the original goal by just adding all the scores:

: bowl ( str -- score )
pins frames scores sum ;

And write a bunch of unit tests to make sure it works:

{ 0 } [ "---------------------" bowl ] unit-test
{ 11 } [ "------------------X1-" bowl ] unit-test
{ 12 } [ "----------------X1-" bowl ] unit-test
{ 15 } [ "------------------5/5" bowl ] unit-test
{ 20 } [ "11111111111111111111" bowl ] unit-test
{ 20 } [ "5/5-----------------" bowl ] unit-test
{ 20 } [ "------------------5/X" bowl ] unit-test
{ 40 } [ "X5/5----------------" bowl ] unit-test
{ 80 } [ "-8-7714215X6172183-" bowl ] unit-test
{ 83 } [ "12X4--3-69/-98/8-8-" bowl ] unit-test
{ 150 } [ "5/5/5/5/5/5/5/5/5/5/5" bowl ] unit-test
{ 144 } [ "XXX6-3/819-44X6-" bowl ] unit-test
{ 266 } [ "XXXXXXXXX81-" bowl ] unit-test
{ 271 } [ "XXXXXXXXX9/2" bowl ] unit-test
{ 279 } [ "XXXXXXXXXX33" bowl ] unit-test
{ 295 } [ "XXXXXXXXXXX5" bowl ] unit-test
{ 300 } [ "XXXXXXXXXXXX" bowl ] unit-test
{ 100 } [ "-/-/-/-/-/-/-/-/-/-/-" bowl ] unit-test
{ 190 } [ "9/9/9/9/9/9/9/9/9/9/9" bowl ] unit-test

This is available on my GitHub.

Sun, 30 Aug 2015 19:30:00

John Benediktsson: Haikunator

The Haikunator is a project to provide "Heroku-like memorable random names". These names usually consist of an adjective, a noun, and a random number or token. The original repository is implemented in Ruby, with ports to Go, Javascript, Python, PHP, Elixer, .NET, Java, and Dart.

We will be implementing this in Factor using the qw vocabulary that provides a simple way to make "arrays of strings" using the qw{ syntax.

First, a list of adjectives:

CONSTANT: adjectives qw{
autumn hidden bitter misty silent empty dry dark summer icy
delicate quiet white cool spring winter patient twilight
dawn crimson wispy weathered blue billowing broken cold
damp falling frosty green long late lingering bold little
morning muddy old red rough still small sparkling throbbing
shy wandering withered wild black young holy solitary
fragrant aged snowy proud floral restless divine polished
ancient purple lively nameless lucky odd tiny free dry
yellow orange gentle tight super royal broad steep flat
square round mute noisy hushy raspy soft shrill rapid sweet
curly calm jolly fancy plain shinny
}

Next, a list of nouns:

CONSTANT: nouns qw{
waterfall river breeze moon rain wind sea morning snow lake
sunset pine shadow leaf dawn glitter forest hill cloud
meadow sun glade bird brook butterfly bush dew dust field
fire flower firefly feather grass haze mountain night pond
darkness snowflake silence sound sky shape surf thunder
violet water wildflower wave water resonance sun wood dream
cherry tree fog frost voice paper frog smoke star atom band
bar base block boat term credit art fashion truth disk
math unit cell scene heart recipe union limit bread toast
bonus lab mud mode poetry tooth hall king queen lion tiger
penguin kiwi cake mouse rice coke hola salad hat
}

We will make a token out of digits:

CONSTANT: token-chars "0123456789"

Finally, a simple haikunate implementation:

: haikunate ( -- str )
adjectives random
nouns random
4 [ token-chars random ] "" replicate-as
"%s-%s-%s" sprintf ;

We can try it a few times, to see how it works:

IN: scratchpad haikunate .
"odd-water-8344"

IN: scratchpad haikunate .
"flat-tooth-9324"

IN: scratchpad haikunate .
"wandering-lion-8346"

IN: scratchpad haikunate .
"yellow-mud-9780"

IN: scratchpad haikunate .
"patient-unit-4203"

IN: scratchpad haikunate .
"floral-feather-1023"

Some versions of "haikunate" in other languages include features such as:

  • allow customization of the delimiter (dots are popular)
  • allow the token to be specified as a range of possible numbers
  • allow the token to be restricted to a maximum length
  • allow the token to be represented using hex digits
  • allow the token to be represented with custom character sets
  • etc.

This is available on my GitHub.

Thu, 27 Aug 2015 02:02:00

John Benediktsson: Random Desktop Background

As a follow-up to my Desktop Background post, I wanted to show how to set your desktop background to random images from various online image sites. We will be downloading a URL to a local file and then setting the desktop picture to that file:

: download-and-set-desktop-picture ( url -- )
dup "/" split1-last nip cache-file
[ download-to ] [ set-desktop-picture ] bi ;

Okay, now we need some random images!

Imgur is a huge image-hosting website frequently used on sites like Reddit.

: random-imgur ( -- url )
"https://imgur.com/random" scrape-html nip
"image_src" "rel" find-by-attribute-key-value
first "href" attribute ;

XKCD has some fun comics. Maybe they would look good on the desktop!

: random-xkcd ( -- url )
"http://dynamic.xkcd.com/random/comic/" http-get nip
R@ http://imgs\.xkcd\.com/comics/[^\.]+\.(png|jpg)@
first-match >string ;

WallpaperStock has a bunch of more traditional desktop images. We will scrape their random wallpaper page, find the first wallpaper thumbnail, load that wallpaper page, find the default image page, and then load that to find the image URL.

: random-wallpaperstock ( -- url )
"http://wallpaperstock.net/random-wallpapers.html"
scrape-html nip "wallpaper_thumb" find-by-class-between
"a" find-by-name nip "href" attribute
"http://wallpaperstock.net" prepend scrape-html nip
"the_view_link" find-by-id nip "href" attribute
"http:" prepend scrape-html nip "myImage" find-by-id nip
"src" attribute "http:" prepend ;

Using this is as easy as:

IN: scratchpad random-imgur
download-and-set-desktop-picture

IN: scratchpad random-xkcd
download-and-set-desktop-picture

IN: scratchpad random-wallpaperstock
download-and-set-desktop-picture

This is available on my GitHub.

Mon, 17 Aug 2015 16:41:00

John Benediktsson: Desktop Background

One of the benefits of learning to program is learning how to automate tasks performed with a computer. I thought it might be fun to build a simple vocabulary to allow getting and setting of the desktop background picture. Since Factor makes it pretty easy to build cross-platform vocabularies, we will implement this on Mac OS X, Linux, and Windows.

Our API consists of two words, one that gets the current desktop picture and one that sets a new desktop picture, dispatching based on which operating system we are running on (technically, based on the value of the os variable).

HOOK: get-desktop-picture os ( -- path )

HOOK: set-desktop-picture os ( path -- )

Mac OS X

On Mac OS X, we use AppleScript to ask the Finder what the path to the current desktop picture is, or tell it to set the desktop picture to a specific path.

M: macosx get-desktop-picture
{
"osascript" "-e"
"tell app \"Finder\" to get posix path of (get desktop picture as alias)"
} utf8 [ readln ] with-process-reader ;

M: macosx set-desktop-picture
absolute-path
"tell application \"Finder\" to set desktop picture to POSIX file \"%s\""
sprintf run-apple-script ;

Windows

On Windows, we use the SystemParametersInfo function to get and set the desktop wallpaper.

CONSTANT: SPI_GETDESKWALLPAPER 0x0073

CONSTANT: SPI_SETDESKWALLPAPER 0x0014

M: windows get-desktop-picture
SPI_GETDESKWALLPAPER MAX_PATH dup 1 + WCHAR <c-array> [
0 SystemParametersInfo win32-error<>0
] keep alien>native-string ;

M: windows set-desktop-picture
[ SPI_SETDESKWALLPAPER 0 ] dip utf16n encode
0 SystemParametersInfo win32-error<>0 ;

Linux

On Linux, which has many different desktops, we are going to assume a GNOME environment. Other window managers have different ways to change the desktop background.

M: linux get-desktop-picture
{
"gsettings"
"get"
"org.gnome.desktop.background"
"picture-uri"
} utf8 [ readln ] with-process-reader
"'file://" ?head drop "'" ?tail drop ;

M: linux set-desktop-picture
{
"gsettings"
"set"
"org.gnome.desktop.background"
"picture-uri"
} swap absolute-path "file://" prepend suffix try-process ;

This is available on my GitHub.

Fri, 14 Aug 2015 15:59:00

John Benediktsson: Automated Reasoning

There was a post about Automated Reasoning in F#, Scala, Haskell, C++, and Julia that uses a simple algorithm from John Harrison's book Handbook of Practical Logic and Automated Reasoning to simplify this equation:

e = (1 + (0 * x)) * 3) + 12

Factor has support for ML-style pattern matching and I thought it would be fun to contribute a simple solution using the match vocabulary.

We want to define a few types of expressions:

TUPLE: Var s ;
TUPLE: Const n ;
TUPLE: Add x y ;
TUPLE: Mul x y ;
Note: we could have made this simpler by assuming integers are constants and strings are variables rather than define the Const and Var tuples, but I wanted to keep this close to the code in the original blog post.

To be able to pattern match, we need to define some match variables:

MATCH-VARS: ?x ?y ;

We want a way to do a single simplification of an expression:

: simplify1 ( expr -- expr' )
{
{ T{ Add f T{ Const f 0 } ?x } [ ?x ] }
{ T{ Add f ?x T{ Const f 0 } } [ ?x ] }
{ T{ Mul f ?x T{ Const f 1 } } [ ?x ] }
{ T{ Mul f T{ Const f 1 } ?x } [ ?x ] }
{ T{ Mul f ?x T{ Const f 0 } } [ T{ Const f 0 } ] }
{ T{ Mul f T{ Const f 0 } ?x } [ T{ Const f 0 } ] }
{ T{ Add f T{ Const f ?x } T{ Const f ?y } }
[ ?x ?y + Const boa ] }
{ T{ Mul f T{ Const f ?x } T{ Const f ?y } }
[ ?x ?y * Const boa ] }
[ ]
} match-cond ;

We have a way to recursively simplify some expressions:

: simplify ( expr -- expr' )
{
{ T{ Add f ?x ?y } [ ?x ?y [ simplify ] bi@ Add boa ] }
{ T{ Mul f ?x ?y } [ ?x ?y [ simplify ] bi@ Mul boa ] }
[ ]
} match-cond simplify1 ;

Finally, we have a word that tries to simplify a value to a constant:

: simplify-value ( expr -- str )
simplify {
{ T{ Const f ?x } [ ?x ] }
[ drop "Could not be simplified to a Constant." ]
} match-cond ;

To check that it works, we can write a unit test that simplifies the original expression above:

{ 15 } [
T{ Add f
T{ Mul f
T{ Add f
T{ Const f 1 }
T{ Mul f
T{ Const f 0 }
T{ Var f "x" } } }
T{ Const f 3 } }
T{ Const f 12 } }
simplify-value
] unit-test

That's cool, but wouldn't it be better if we could work on quotations directly? Let's make a word that converts a quotation to an expression:

: >expr ( quot -- expr )
[
{
{ [ dup string? ] [ '[ _ Var boa ] ] }
{ [ dup integer? ] [ '[ _ Const boa ] ] }
{ [ dup \ + = ] [ drop [ Add boa ] ] }
{ [ dup \ * = ] [ drop [ Mul boa ] ] }
} cond
] map concat call( -- expr ) ;

Now that we have that, our test case is a lot simpler:

{ 15 } [
[ "x" 0 * 1 + 3 * 12 + ] >expr simplify-value
] unit-test

The code for this is on my GitHub.

Note: this takes advantage of a small feature that I added to the match-cond word to provide a way to easily handle a fall-through pattern like the cond word.

Fri, 7 Aug 2015 00:04:00

John Benediktsson: Bit Test

Factor has a bit? generic that is used to test an integer to see if a particular bit is set. When operating on fixnum integers, this is implemented by the fixnum-bit? word:

: fixnum-bit? ( x n -- ? )
{ fixnum fixnum } declare
dup 0 >= [ neg shift even? not ] [ 2drop f ] if

Many CPU architectures have instructions for performing a Bit Test. On x86, the BT instruction is available. Below, we are going to implement a compiler intrinsic in the hopes of speeding up this operation in Factor.

Intrinsic

In cpu.architecture, add a generic %bit-test based on our CPU:

HOOK: %bit-test cpu ( dst src1 src2 temp -- )

In cpu.x86, implement %bit-test on x86 (returning a boolean using a temporary register and the CMOVB instruction to check the carry flag which holds the result of the bit test):

M:: x86 %bit-test ( dst src1 src2 temp -- )
src1 src2 BT
dst temp \ CMOVB (%boolean) ;

In compiler.cfg.instructions, add a ##bit-test instruction:

FOLDABLE-INSN: ##bit-test
def: dst/tagged-rep
use: src1/int-rep src2/int-rep
temp: temp/int-rep ;

In compiler.codegen, we link the ##bit-test instruction with the %bit-test word.

CODEGEN: ##bit-test %bit-test

In compiler.cfg.intrinsics, enable replacing fixnum-bit? with the %bit-test intrinsic:

: enable-bit-test ( -- )
{
{ fixnum-bit? [ drop [ ^^bit-test ] binary-op ] }
} enable-intrinsics ;

Disassemble

The old assembly using fixnum-bit? looked like this:

000000010ea00250: mov [rip-0x1ff256], eax
000000010ea00256: sub rsp, 0x8
000000010ea0025a: call 0x10eedf3b0 (integer>fixnum-strict)
000000010ea0025f: mov rax, [r14]
000000010ea00262: cmp rax, 0x0
000000010ea00266: jl 0x10ea002a7 (M\ fixnum bit? + 0x57)
000000010ea0026c: neg rax
000000010ea0026f: mov [r14], rax
000000010ea00272: call 0x10ebec060 (fixnum-shift)
000000010ea00277: mov rax, [r14]
000000010ea0027a: test rax, 0x10
000000010ea00281: mov rax, 0x1
000000010ea0028b: mov rbx, 0x1010eff4c
000000010ea00295: cmovnz rax, rbx
000000010ea00299: mov [r14], rax
000000010ea0029c: mov [rip-0x1ff2a2], eax
000000010ea002a2: add rsp, 0x8
000000010ea002a6: ret
000000010ea002a7: sub r14, 0x8
000000010ea002ab: mov qword [r14], 0x1
000000010ea002b2: mov [rip-0x1ff2b8], eax
000000010ea002b8: add rsp, 0x8
000000010ea002bc: ret

The new assembly looks like this with BT:

000000010e656ec0: mov [rip-0x293ec6], eax
000000010e656ec6: sub rsp, 0x8
000000010e656eca: call 0x10e467ea0 (integer>fixnum-strict)
000000010e656ecf: mov rax, [r14]
000000010e656ed2: mov rbx, [r14-0x8]
000000010e656ed6: sar rbx, 0x4
000000010e656eda: sar rax, 0x4
000000010e656ede: bt rbx, rax
000000010e656ee2: mov rbx, 0x1
000000010e656eec: mov rcx, 0x1018f169c
000000010e656ef6: cmovb rbx, rcx
000000010e656efa: sub r14, 0x8
000000010e656efe: mov [r14], rbx
000000010e656f01: mov [rip-0x293f07], eax
000000010e656f07: add rsp, 0x8
000000010e656f0b: ret

Performance

Turns out that this speeds up fixnum-bit? by a lot. Using a simple test case:

: bench-fixnum-bit ( x n -- ? )
{ fixnum fixnum } declare
[ 0 100,000,000 ] 2dip
'[ _ _ bit? [ 1 + ] when ] times ;

Our old version was decently fast:

IN: scratchpad gc [ 0b101010101 0 bench-fixnum-bit ] time
Running time: 0.821433838 seconds

But our new version is much faster!

IN: scratchpad gc [ 0b101010101 0 bench-fixnum-bit ] time
Running time: 0.239439108 seconds

This has been committed to the development version and is available now.

Fri, 19 Jun 2015 15:30:00

John Benediktsson: Compressed Sieve of Eratosthenes

In my previous post, we used "2-3-5-7" wheel factorization to produce a faster Sieve of Eratosthenes with a compression factor of 2 (by storing only the odd numbers). Samuel Tardieu reminded me that the sieve variation used by Factor uses less memory with a higher compression factor of 3.75.

I thought would be a fun implementation to show below.

Version 6

The "2-3-5" wheel with the first 30 numbers that are not divisible by 2, 3, or 5.

CONSTANT: wheel-2-3-5 $[
30 [1,b] [
{ 2 3 5 } [ divisor? ] with any? not
] B{ } filter-as
]
Note: We use 30 here because the "{ 2 3 5 } product" cycle is 30.

If you look at the wheel, you see that there are 8 candidates in every 30 numbers:

IN: scratchpad wheel-2-3-5 .
{ 1 7 11 13 17 19 23 29 }

The number 8 is interesting because it suggests that we can use a single byte to store the 8 candidates in each block of 30 numbers, using a bitmask for possible primes or f:

CONSTANT: masks $[
30 [0,b) [
wheel-2-3-5 index [ 7 swap - 2^ ] [ f ] if*
] map
]

We can index into this array to find the byte/mask for every number:

: byte-mask ( n -- byte mask/f )
30 /mod masks nth ;

Using the byte/mask we can check if a number is marked in the sieve byte-array.

:: marked? ( n sieve -- ? )
n byte-mask :> ( byte mask )
mask [ byte sieve nth mask bitand zero? not ] [ f ] if ;

And we can unmark a number in the sieve in a similar fashion:

:: unmark ( n sieve -- )
n byte-mask :> ( byte mask )
mask [ byte sieve [ mask bitnot bitand ] change-nth ] when ;

Using that, we can unmark multiples of prime numbers:

:: unmark-multiples ( i upper sieve -- )
i sq upper i 2 * <range> [ sieve unmark ] each ;

That's all we need to build our sieve, starting from a byte-array initialized with all numbers marked and then progressively unmarking multiples of primes:

:: sieve6 ( n -- sieve )
n 30 /i 1 + [ 0xff ] B{ } replicate-as :> sieve
sieve length 30 * 1 - :> upper
3 upper sqrt 2 <range> [| i |
i sieve marked? [
i upper sieve unmark-multiples
] when
] each sieve ;

As you can see, storing prime numbers up to 10 million takes only 333 KB!

IN: scratchpad 10,000,000 sieve6 length .
333334

This approach is used by the math.primes vocabulary to quickly check primality of any number less than 9 million using only 300 KB of memory.

Neat!

Wed, 17 Jun 2015 17:10:00

John Benediktsson: Genuine Sieve of Eratosthenes

Iain Gray posted on the mailing list about a paper called the Genuine Sieve of Eratosthenes by Melissa O'Neill, a Professor of Computer Science at Harvey Mudd College.

It begins with a discussion about some clever looking Haskell code that is just trial division and not the Sieve of Eratosthenes. At the end of the paper is an interesting discussion of performance improvements that I thought might be fun to implement in Factor as a followup to the three versions that I posted about recently.

Version 4

We are going to use wheel factorization as a way of reducing the search space by ignoring some multiples of small prime numbers. It is a bit similar to ignoring all even numbers in our previous "Version 3". In this case, we want to ignore all multiples of the first four prime numbers.

To calculate the "2-3-5-7" wheel, we start with 11 and filter the next 210 numbers that are not divisible by 2, 3, 5, or 7.

CONSTANT: wheel-2-3-5-7 $[
11 dup 210 + [a,b] [
{ 2 3 5 7 } [ divisor? ] with any? not
] B{ } filter-as differences
]
Note: We use 210 here because the "{ 2 3 5 7 } product" cycle is 210.

Next, we want a way to iterate across all the numbers that might be prime, calling a quotation on each number that is prime.

:: each-prime ( upto sieve quot -- )
11 upto '[ dup _ <= ] [
wheel-2-3-5-7 [
over dup 2/ sieve nth [ drop ] quot if
+
] each
] while drop ; inline

For each prime found, we will want to mark all odd multiples as not prime.

:: mark-multiples ( i upto sieve -- )
i sq upto i 2 * <range> [| j |
t j 2/ sieve set-nth
] each ; inline

We will use a bit-array that is sized in 210-bit blocks, so the number of bits needed is:

: sieve-bits ( n -- bits )
210 /i 1 + 210 * 2/ 6 + ; inline

Finally, we calculate our sieve, first for 11 and then for all the primes above 11.

:: sieve4 ( n -- primes )
n sieve-bits <bit-array> :> sieve
t 0 sieve set-nth
t 4 sieve set-nth
n sqrt sieve [ n sieve mark-multiples ] each-prime
V{ 2 3 5 7 } clone :> primes
n sieve [
dup n <= [ primes push ] [ drop ] if
] each-prime primes ;

Calculating prime numbers up to 10 million is getting even faster.

IN: scratchpad gc [ 10,000,000 sieve4 ] time
Running time: 0.08523477 seconds

Version 5

If you use the compiler.tree.debugger to inspect the optimized output, you can see some dynamic dispatch with branches for fixed-width (fixnum) and arbitrary-precision (bignum) integers.

It would be nice to perform fixnum specialization or improve type propagation in the compiler, but for now we are going to write some ugly code to force fixnum math for performance.

We make a version of each-prime that inlines the iteration:

:: each-prime2 ( upto sieve quot -- )
11 upto >fixnum '[ dup _ <= ] [
wheel-2-3-5-7 [
over dup 2/ sieve nth-unsafe [ drop ] quot if
fixnum+fast
] each
] while drop ; inline

And similarly for mark-multiples:

:: mark-multiples2 ( i upto sieve -- )
i 2 fixnum*fast :> step
i i fixnum*fast upto >fixnum '[ dup _ <= ] [
t over 2/ sieve set-nth-unsafe
step fixnum+fast
] while drop ; inline

And use them in our sieve computation:

:: sieve5 ( n -- primes )
n sieve-bits <bit-array> :> sieve
t 0 sieve set-nth
t 4 sieve set-nth
n sqrt sieve [ n sieve mark-multiples2 ] each-prime2
V{ 2 3 5 7 } clone :> primes
n sieve [
dup n <= [ primes push ] [ drop ] if
] each-prime2 primes ;

Calculating prime numbers up to 10 million is super fast!

IN: scratchpad gc [ 10,000,000 sieve5 ] time
Running time: 0.033914378 seconds

We can compute all the 11,078,937 prime numbers up to 200 million in about a second!

IN: scratchpad gc [ 200,000,000 sieve5 ] time
Running time: 0.970876855 seconds

And all the 50,847,534 prime numbers up to 1 billion in about six seconds!

IN: scratchpad gc [ 1,000,000,000 sieve5 ] time
Running time: 6.141224805 seconds

Not quite primegen or primesieve, but not bad for a laptop!

This is available in the math.primes.erato.fast vocabulary on our nightly builds!

Mon, 8 Jun 2015 22:48:00

Blogroll


planet-factor is an Atom/RSS aggregator that collects the contents of Factor-related blogs. It is inspired by Planet Lisp.

Syndicate