Setting Attributes

One test of dynamic languages is to try and set attribute values on an object dynamically (e.g., without knowing until runtime which attributes need to be set). Below, we compare a simple example in Python, a fairly dynamic language, to Factor:

class Foo(object):
    a, b, c = None, None, None

obj = Foo()

d = { "a" : 1, "b" : 2 }
obj.a = d.get("a")
obj.b = d.get("b")
obj.c = d.get("c")

print obj.a # 1
print obj.b # 2
print obj.c # None

We might directly translate the previous example to Factor code, using slot accessors to set attributes on the tuple instance:

TUPLE: foo a b c ;

foo new

H{ { "a" 1 } { "b" 2 } } {
    [ "a" swap at >>a ]
    [ "b" swap at >>b ] 
    [ "c" swap at >>c ] 
} cleave

[ a>> . ] [ b>> . ] [ c>> . ] tri

But, it's much better if you don't need to know ahead of time which attributes a class has (i.e., needing to write code to handle each attribute). In Python, you might instead set each value dynamically using the setattr function:

for name, value in d.items():
    setattr(obj, name, value)

We can use the set-slot-named word from the db.types vocabulary to do the same from Factor:

USING: assocs db.types fry kernel ;

: set-slots ( assoc obj -- )
    '[ swap _ set-slot-named ] assoc-each ;

Note: the set-slot-named word (and the offset-of-slot word that it uses) should probably be moved to the slots vocabulary.

We can simplify the previous example using our newly created set-slots word and try it in the Factor listener:

( scratchpad ) TUPLE: foo a b c ;

( scratchpad ) foo new

( scratchpad ) H{ { "a" 1 } { "b" 2 } } over set-slots .
T{ foo { a 1 } { b 2 } }

Trashing Files: Part 3 (Windows)

In Part 1 and Part 2, we implemented send-to-trash on Mac OS and other Unix-like systems. In Part 3, we will be implementing support for the Windows Recycle Bin using Factor.

trash.windows

First, we create the trash.windows vocabulary:

USING: accessors alien.c-types alien.data alien.strings
alien.syntax classes.struct classes.struct.packed destructors
kernel io.encodings.utf16n libc math sequences system trash
windows.types ;

IN: trash.windows

We will be using the alien vocabulary to call the SHFileOperationW function from the shell32.dll library. Unfortunately, this function expects a "packed structure" (e.g., without data structure padding), so I needed to add support for this first (in the classes.struct.packed vocabulary). Using this, the PACKED-STRUCT: word creates a structure with each field aligned to a single byte.

LIBRARY: shell32

TYPEDEF: WORD FILEOP_FLAGS

PACKED-STRUCT: SHFILEOPSTRUCTW
    { hwnd HWND }
    { wFunc UINT }
    { pFrom LPCWSTR* }
    { pTo LPCWSTR* }
    { fFlags FILEOP_FLAGS }
    { fAnyOperationsAborted BOOL }
    { hNameMappings LPVOID }
    { lpszProgressTitle LPCWSTR } ;

FUNCTION: int SHFileOperationW ( SHFILEOPSTRUCTW* lpFileOp ) ;

CONSTANT: FO_DELETE HEX: 0003

CONSTANT: FOF_SILENT HEX: 0004
CONSTANT: FOF_NOCONFIRMATION HEX: 0010
CONSTANT: FOF_ALLOWUNDO HEX: 0040
CONSTANT: FOF_NOERRORUI HEX: 0400

With these defined, we can implement send-to-trash, by simply creating the SHFILEOPSTRUCTW structure (making sure to add extra null bytes to the end of the path being trashed -- since it should be "double null terminated"), and then performing the SHFileOperationW function.

M: windows send-to-trash ( path -- )
    [
        utf16n string>alien B{ 0 0 } append
        malloc-byte-array &free

        SHFILEOPSTRUCTW <struct>
            f >>hwnd
            FO_DELETE >>wFunc
            swap >>pFrom
            f >>pTo
            FOF_ALLOWUNDO
            FOF_NOCONFIRMATION bitor
            FOF_NOERRORUI bitor
            FOF_SILENT bitor >>fFlags

        SHFileOperationW [ throw ] unless-zero

    ] with-destructors ;

The code for this is on my Github.

Trashing Files: Part 2 (Unix)

In Part 1, we implemented send-to-trash on Mac OS. In Part 2, we will be adding Factor support for the FreeDesktop.org Trash Specification used on other Unix systems (e.g., Linux or BSD).

trash.unix

First, we need to create the trash.unix vocabulary:

USING: accessors calendar combinators.short-circuit environment
formatting io io.directories io.encodings.utf8 io.files
io.files.info io.files.info.unix io.files.types io.pathnames
kernel math math.parser sequences system trash unix.stat
unix.users ;

IN: trash.unix

When trashing a file, we sometimes need to look for the "top directory" of a mounted resource that contains a given path. We can use the lstat function (using the link-status word from unix.stat) to read information about the file or symbol link pointed to by a path. If the file system details are different between a path and its parent directory, then it is the top directory of a mounted resource.

: top-directory? ( path -- ? )
    dup ".." append-path [ link-status ] bi@
    [ [ st_dev>> ] bi@ = not ] [ [ st_ino>> ] bi@ = ] 2bi or ;

: top-directory ( path -- path' )
    [ dup top-directory? not ] [ ".." append-path ] while ;

We need to be able to create trash directories with "user-only" permissions:

: make-user-directory ( path -- )
    [ make-directories ] [ OCT: 700 set-file-permissions ] bi ;

To be a valid trash path, we need to check:

1. The path is to a directory
2. The path has the sticky-bit set
3. The path should not be a symbolic link

: check-trash-path ( path -- )
    {
        [ file-info directory? ]
        [ sticky? ]
        [ link-info type>> +symbolic-link+ = not ]
    } 1&& [ "invalid trash path" throw ] unless ;

The FreeDesktop.org Trash Specification defines various locations for the trash directory, in order of preference:

1. In $XDG_DATA_HOME/Trash (or $HOME/.local/share/Trash), if the file being trashed is on the same mount point.
2. In the top directory of the path's mount point, $TOPDIR/.Trash/$UID, if the .Trash directory is available.
3. In the top directory of the path's mount point, $TOPDIR/.Trash-$UID, in a user-created directory.

: trash-home ( -- path )
    "XDG_DATA_HOME" os-env
    home ".local/share" append-path or
    "Trash" append-path dup check-trash-path ;

: trash-1 ( root -- path )
    ".Trash" append-path dup check-trash-path
    real-user-id number>string append-path ;

: trash-2 ( root -- path )
    real-user-id ".Trash-%d" sprintf append-path ;

: trash-path ( path -- path' )
    top-directory dup trash-home top-directory = [
        drop trash-home
    ] [
        dup ".Trash" append-path exists?
        [ trash-1 ] [ trash-2 ] if
        [ make-user-directory ] keep
    ] if ;

We need to implement some logic to handle name collisions (e.g., when trashing a file with the same name as a file already in the trash directory). To do this, we use "safe" filenames (adding an incrementing extension to ensure uniqueness):

: (safe-file-name) ( path counter -- path' )
    [
        [ parent-directory ]
        [ file-stem ]
        [ file-extension dup [ "." prepend ] when ] tri
    ] dip swap "%s%s %s%s" sprintf ;

: safe-file-name ( path -- path' )
    dup 0 [ over exists? ] [
        [ parent-directory to-directory ] [ 1 + ] bi*
        [ (safe-file-name) ] keep
    ] while drop nip ;

And, finally, we can implement the send-to-trash logic:

1. Lookup the trash path for the file being trashed
2. Move the trashed file into a files sub-directory, using a safe file name
3. Create an "information file" in an info sub-directory, with details of the trashed file.

M: unix send-to-trash ( path -- )
    dup trash-path [
        "files" append-path [ make-user-directory ] keep
        to-directory safe-file-name
    ] [
        "info" append-path [ make-user-directory ] keep
        to-directory ".trashinfo" append [ over ] dip utf8 [
            "[Trash Info]" write nl
            "Path=" write write nl
            "DeletionDate=" write
            now "%Y-%m-%dT%H:%M:%S" strftime write nl
        ] with-file-writer
    ] bi move-file ;

The code for this is on my Github.

Trashing Files: Part 1 (Mac OS)

Most operating systems provide support for sending files to the "trash can" (or sometimes "recycle bin"). Inspired by a python project called "send2trash", I thought Factor should have a similar cross-platform library for trashing files.

trash

First, we are going to define a trash vocabulary, and use a HOOK: that dispatches to the proper implementation, depending on which operating system you are running.

USING: combinators system vocabs.loader ;

IN: trash

HOOK: send-to-trash os ( path -- )

{
    { [ os macosx? ] [ "trash.macosx"  ] }
    { [ os unix?   ] [ "trash.unix"    ] }
    { [ os winnt?  ] [ "trash.windows" ] }
} cond require

trash.macosx

Next, we will create the trash.macosx vocabulary.

USING: alien.c-types alien.strings alien.syntax classes.struct
core-foundation io.encodings.utf8 kernel system trash ;

IN: trash.macosx

On the Mac OS, there are several methods of moving files to the trash. A good discussion on CocoaDev lists some of them. We are going to use the alien vocabulary to make calls into the File Manager in the CarbonCore.framework. Some functions will return an OSStatus flag (a signed 32-bit integer) to indicate if the operation succeeded. We will add a TYPEDEF: for it, and then define the GetMacOSStatusCommentString function that converts the status flag into a human readable error.

TYPEDEF: SInt32 OSStatus

FUNCTION: char* GetMacOSStatusCommentString ( OSStatus err ) ;

: check-err ( err -- )
    [ GetMacOSStatusCommentString utf8 alien>string throw ] 
    unless-zero ;

Many of the file operations act on an FSRef structure which represents a path within the file system. We will define the FSPathMakeRefWithOptions function which will allow us to create these references:

STRUCT: FSRef { hidden UInt8[80] } ;

TYPEDEF: UInt32 OptionBits

FUNCTION: OSStatus FSPathMakeRefWithOptions (
    UInt8* path,
    OptionBits options,
    FSRef* ref,
    Boolean* isDirectory
) ;

We can then make a <fs-ref> word for creating references, given a path to a file (or directory).

CONSTANT: kFSPathMakeRefDoNotFollowLeafSymlink HEX: 01

: <fs-ref> ( path -- fs-ref )
    utf8 string>alien
    kFSPathMakeRefDoNotFollowLeafSymlink
    FSRef <struct>
    [ f FSPathMakeRefWithOptions check-err ] keep ;

There are several ways of "trashing" files, but one recommended way is implemented by the FSMoveObjectToTrashSync function:

FUNCTION: OSStatus FSMoveObjectToTrashSync (
    FSRef* source,
    FSRef* target,
    OptionBits options
) ;

Implementing the send-to-trash word is now pretty straightforward:

CONSTANT: kFSFileOperationDefaultOptions HEX: 00

M: macosx send-to-trash ( path -- )
    <fs-ref> f kFSFileOperationDefaultOptions
    FSMoveObjectToTrashSync check-err ;

You can test this by creating a temporary file (e.g., /tmp/foo), sending it to the trash, and then verifying that it exists by looking in the Finder's Trash.

( scratchpad ) USING: trash io.encodings.ascii io.files ;

( scratchpad ) "" "/tmp/foo" ascii set-file-contents

( scratchpad ) "/tmp/foo" send-to-trash

Note: This method does not appear to support the "Put Back" functionality (to "undo" the trash operation). Perhaps there is some metadata that we can add (or a different function we can call) that will track the original file location so that the Finder knows where it should be restored to.

The code for this is on my Github.

Configuration Files

Factor can use several configuration files as part of its startup routine.

factor-rc

At startup, Factor looks for a .factor-rc (or factor-rc on Windows) file in your $HOME directory. If found, it will attempt to run the contents of this file as Factor source code.

For example, if you'd like to have Factor print "Hello, World!" when it starts up, you can modify your factor-rc file to say:

USE: io
"Hello, World!" print

Then try and start Factor from the command-line and it should look something like this:

$ factor
Loading $HOME/.factor-rc
Hello, World!
( scratchpad ) 

More practically, if you want to always use a particular editor with Factor (e.g., MacVim), you can USE: it in your factor-rc:

USE: editors.macvim

For more information, see run-user-init.

factor-boot-rc

When performing the bootstrap process (e.g., making a new VM image), Factor looks for the .factor-boot-rc (or factor-boot-rc on Windows) file in your $HOME directory. In this file, you can use the require word to load vocabularies you use frequently.

For example, if you'd like to have the formatting vocabulary code loaded into the image (for the printf word), you can add this to your factor-boot-rc file:

USE: vocabs.loader
"formatting" require

The next time you bootstrap Factor, the new image should have loaded the formatting vocabulary.

For more information, see run-bootstrap-init.

factor-roots

By default, Factor looks in $FACTOR/core, $FACTOR/basis, $FACTOR/extra, and $FACTOR/work for vocabularies. It is frequently useful to specify additional vocabulary roots. Factor looks for the .factor-roots (or factor-roots on Windows) in your $HOME directory for additional vocabulary paths.

For example, if you want to use the code I've written as part of this blog, then you can checkout the re-factor code somewhere. Then, add the full path to the re-factor directory as a line in the factor-roots file. Next time you run Factor, you should be able to USE: vocabularies from re-factor.

For more information, see load-vocab-roots and add-vocab-roots.

Genetic Hello World

A recent article called Genetic Algorithm for Hello World describes the basic concepts involved in programming genetic algorithms. The original implementation is in Javascript, and has a nice online simulator. I thought it would be fun to contribute an implementation in Factor.

Genetic algorithms are generally comprised of the following concepts:

1. A target chromosome which expresses a possible solution to the problem
2. A fitness function which takes a chromosome as input and returns a higher value for better solutions
3. A population which is just a set of many chromosomes
4. A selection method which determines how parents are selected for breeding from the population
5. A crossover operation which determines how parents combine to produce offspring
6. A mutation operation which determines how random deviations manifest themselves

First, we need to define the vocabularies that we will use and a namespace:

USING: fry kernel make math math.order math.ranges random
sequences ;

IN: hello-ga

Target

Our goal is to generate the target string "Hello World!".

CONSTANT: TARGET "Hello World!"

Fitness

The fitness of a chromosome is the "sum of the character-wise differences between the chromosome and the target string".

: fitness ( chromosome -- n )
    TARGET 0 [ - abs - ] 2reduce ;

Population

Our starting population will be made up by "creating 400 totally random 12 character strings".

CONSTANT: POPULATION 400

: random-chromosome ( -- chromosome )
    TARGET length [ 256 random ] "" replicate-as ;

: random-population ( -- seq )
    POPULATION [ random-chromosome ] replicate ;

Selection

We select two parents to survive or breed into the next generation by "taking two members of the population at complete random and keep the fittest as the first parent, then do the same with another two members and keep the fittest as the other parent".

: fittest ( parent1 parent2 -- parent1' parent2' )
    2dup [ fitness ] bi@ > [ swap ] when ;

: tournament ( seq -- parent )
    dup [ random ] bi@ fittest nip ;

: parents ( seq -- parent1 parent2 )
    dup [ tournament ] bi@ ;

Crossover

After choosing two parents, we want to "ensure their genes survive in the next generation". Sometimes (10% chance) the parents survive into the next generation, but most frequently, we mix the parents by picking a split point and then making one child from the head of parent1 plus tail of parent2 and another from the head of parent2 plus tail of parent1.

CONSTANT: CHILDREN-PROBABILITY 0.9

: children? ( -- ? )
    0.0 1.0 uniform-random-float CHILDREN-PROBABILITY < ;

: head/tail ( seq1 seq2 n -- head1 tail2 )
    [ head ] [ tail ] bi-curry bi* ;

: tail/head ( seq1 seq2 n -- tail1 head2 )
    [ tail ] [ head ] bi-curry bi* ;

: children ( parent1 parent2 -- child1 child2 )
    TARGET length 1 - [1,b) random
    [ head/tail append ] [ tail/head prepend ] 3bi ;

Mutation

When a mutation occurs (20% chance), we "choose a random position and alter the character that's there by up to 5 places".

CONSTANT: MUTATION-PROBABILITY 0.2

: mutation? ( -- ? )
    0.0 1.0 uniform-random-float MUTATION-PROBABILITY < ;

: mutate ( chromosome -- chromosome' )
    dup length random over [ -5 5 [a,b] random + ] change-nth ;

Simulation

Perform a single generation by selecting the parents (or children) and allowing mutations to occur. We do this in such a way that the number of chromosomes in each generation remains constant.

: (1generation) ( seq -- child1 child2 )
    parents children? [ children ] when
    mutation? [ [ mutate ] bi@ ] when ;

: 1generation ( seq -- seq' )
    [ length 2 / ] keep
    '[ _ [ _ (1generation) , , ] times ] { } make ;

Computing all generations required to achieve the target string is fairly easy:

: finished? ( seq -- ? )
    TARGET swap member? ;

: all-generations ( seq -- seqs )
    [
        [ 1generation dup , dup finished? not ] loop drop
    ] { } make ;

Try It

Compute all generations for a random population.

( scratchpad ) random-population all-generations

See how many generations it took.

( scratchpad ) dup length .
56

See how the fitness of the best chromosome changes over the generations.

( scratchpad ) dup [ [ fitness ] [ max ] map-reduce ] map .
{
    -414
    -382
    -329
    -288
    -271
    -238
    -217
    -191
    -169
    -167
    -160
    -143
    -134
    -113
    -119
    -94
    -83
    -79
    -63
    -59
    -61
    -54
    -50
    -43
    -39
    -38
    -36
    -31
    -32
    -32
    -28
    -27
    -22
    -18
    -15
    -15
    -14
    -13
    -13
    -11
    -11
    -10
    -8
    -7
    -7
    -7
    -6
    -6
    -4
    -4
    -3
    -3
    -2
    -2
    -2
    0
}

The code is available on my Github.

Estimating CPU Speed

Factor contains a nice DSL for writing assembly code. I thought it would be fun to investigate how it works by accessing the CPU's Time Stamp Counter to estimate CPU speed.

The X86 instruction for accessing the timestamp value (incremented every CPU tick) is called RDTSC (a 2-byte instruction 0x0f 0x31). Some C code for calling the 32-bit or 64-bit versions of this looks like:

#if defined(__i386__)

static __inline__ unsigned long long rdtsc(void)
{
    unsigned long long int x;
    __asm__ __volatile__ (".byte 0x0f, 0x31" : "=A" (x));
    return x;
}

#elif defined(__x86_64__)

static __inline__ unsigned long long rdtsc(void)
{
    unsigned long long hi, lo;
    __asm__ __volatile__ ("rdtsc" : "=a"(lo), "=d"(hi));
    return ( (unsigned long long)lo)|( ((unsigned long long)hi)<<32 );
}

#endif

Factor provides utilities for calling arbitrary assembly code in the alien vocabulary. Using this, we can create corresponding Factor code (supporting both 32 and 64 bits):

USING: alien alien.c-types cpu.x86.assembler
cpu.x86.assembler.operands system ;

HOOK: rdtsc cpu ( -- n )

M: x86.32 rdtsc
    longlong { } cdecl [
        RDTSC
    ] alien-assembly ;

M: x86.64 rdtsc
    longlong { } cdecl [
        RAX 0 MOV
        RDTSC
        RDX 32 SHL
        RAX RDX OR
    ] alien-assembly ;

You can see in the implementation above how Factor uses the type of CPU (contained in the cpu variable) to dispatch on the correct version of the rdtsc word.

To estimate CPU speed, we will need to define two "benchmarking" words:

1. Calculate the number of CPU ticks it takes to execute some Factor code.
2. Calculate the time it takes to execute some Factor code.

USING: kernel math system ;

: #ticks ( quot -- n )
    rdtsc [ call rdtsc ] dip - ; inline

: #nanos ( quot -- n )
    nano-count [ call nano-count ] dip - ; inline

We can then create a "busy loop" that runs for some time, then estimates CPU speed as ticks-per-second:

: busy-loop ( -- )
    100000000 [ 1 - dup 0 > ] loop drop ;

: cpu-speed ( -- n )
    [ [ busy-loop ] #nanos ] #ticks swap / 1000000000.0 * ;

Running this on my MacBook Pro (with a 2.66 GHz processor) produces this estimate:

( scratchpad ) cpu-speed .
2660324566.190773

The rdtsc and #ticks words are distributed with Factor as instruction-count and count-instructions and are available in the cpu.x86.features vocabulary. The #nanos word is called benchmark and is available in the tools.time vocabulary.