Factor meets the Stanford Bunny

I ported another one of Jon D. Harrop's Ocaml demos to Factor, this time the Stanford Bunny. From the page: "The Stanford bunny is a 3D mesh of triangles commonly used as a benchmark for computer graphics applications."

Screenshot:


I found an FFI bug while working on this; on Mac OS X, Factor would spill floating point parameters on the C stack if there was more than 8 of them, however this is only correct for Linux. The Mac OS X PowerPC ABI stipulates that the first 13 floating point parameters are passed in registers.

I also had a problem where the depth buffer was not working on Mac OS X. Thanks to Kevin P. Reid (kpreid on #concatenative) who asked:

kpreid: well, did you ask for a depth buffer? :)

Turns out I did not ask for a depth buffer, and I had to change the code which creates the Cocoa GLView to request one. This is not a good solution since now every UI window has a depth buffer, wasting memory. And of course at some point somebody will come along and want to do something with accumulation buffers, stereo display, and other odd stuff. So eventually I'll need a portable way to configure the GL context. For now, changing the Cocoa, X11 and Windows UI backends to always request a depth buffer will suffice.

I wanted to ship this demo with Factor, but the data file is 2.9 Mb. So what the program does is download the data file (using libs/http-client) and save it the first time it is run. Clean and elegant.

Source code - this time it's only 4 lines longer than the Ocaml version:

! From http://www.ffconsultancy.com/ocaml/bunny/index.html
USING: alien-contrib arrays sequences math io kernel
matrices opengl shuffle gadgets http-client tools
vectors timers namespaces ;
IN: bunny

: numbers ( str -- seq )
    " " split [ string>number ] map [ ] subset ;

: (parse-model) ( vs is -- vs is )
    readln [
        numbers {
            { [ dup length 5 = ] [ 3 head pick push ] }
            { [ dup first 3 = ] [ 1 tail over push ] }
            { [ t ] [ drop ] }
        } cond (parse-model)
    ] when* ;

: parse-model ( stream -- vs is )
    [
        100000 <vector> 100000 <vector> (parse-model)
    ] with-stream
    [
        over length # " vertices, " %
        dup length # " triangles" %
    ] "" make print ;

: n ( vs triple -- n )
    [ swap nth ] map-with
    dup third over first v- >r dup second swap first v- r> cross
    vneg normalize ;

: normal ( ns vs triple -- )
    [ n ] keep [ rot [ v+ ] change-nth ] each-with2 ;

: normals ( vs is -- ns )
    over length { 0.0 0.0 0.0 } <array> -rot
    [ >r 2dup r> normal ] each drop
    [ normalize ] map ;

: read-model ( stream -- model )
    "Reading model" print flush [
        <file-reader> parse-model [ normals ] 2keep 3array
    ] time ;

: model-path "demos/bunny/bun_zipper.ply" ;

: model-url "http://factorcode.org/bun_zipper.ply" ;

: maybe-download ( -- path )
    model-path resource-path dup exists? [
        "Downloading bunny from " write
        model-url dup print flush
        over download
    ] unless ;

: draw-triangle ( ns vs triple -- )
    [
        dup roll nth first3 glNormal3d
        swap nth first3 glVertex3d
    ] each-with2 ;

: draw-bunny ( ns vs is -- )
    GL_TRIANGLES [ [ draw-triangle ] each-with2 ] do-state ;

: cache-bunny ( triple -- displaylist )
    GL_COMPILE [ first3 draw-bunny ] make-dlist ;

TUPLE: bunny-gadget dlist model ;

C: bunny-gadget ( model -- gadget )
    <gadget> over set-gadget-delegate
    [ set-bunny-gadget-model ] keep ;

M: bunny-gadget graft* 10 10 add-timer ;

M: bunny-gadget ungraft*
    dup remove-timer
    bunny-gadget-dlist [ delete-dlist ] when* ;

M: bunny-gadget tick relayout-1 ;

: aspect ( gadget -- x ) rect-dim first2 /f ;

: cache-bunny-dlist ( gadget -- dlist )
    dup bunny-gadget-dlist [ ] [
        dup bunny-gadget-model cache-bunny
        dup rot set-bunny-gadget-dlist
    ] ?if ;

M: bunny-gadget draw-gadget*
    GL_DEPTH_TEST glEnable
    GL_SCISSOR_TEST glDisable
    1.0 glClearDepth
    GL_DEPTH_BUFFER_BIT glClear
    0.0 0.0 0.0 1.0 glClearColor
    GL_COLOR_BUFFER_BIT glClear
    GL_PROJECTION glMatrixMode
    glLoadIdentity
    45.0 over aspect 0.1 1.0 gluPerspective
    0.0 0.12 -0.25  0.0 0.1 0.0  0.0 1.0 0.0 gluLookAt
    GL_MODELVIEW glMatrixMode
    glLoadIdentity
    GL_LEQUAL glDepthFunc
    GL_LIGHTING glEnable
    GL_LIGHT0 glEnable
    GL_COLOR_MATERIAL glEnable
    GL_LIGHT0 GL_POSITION { 1.0 -1.0 1.0 1.0 } >float-array glLightfv
    millis 24000 mod 0.015 * 0.0 1.0 0.0 glRotated
    GL_FRONT_AND_BACK GL_SHININESS 100.0 glMaterialf
    GL_FRONT_AND_BACK GL_SPECULAR glColorMaterial
    GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE glColorMaterial
    0.6 0.5 0.5 1.0 glColor4d
    cache-bunny-dlist glCallList ;

M: bunny-gadget pref-dim* drop { 400 300 } ;

: bunny-window ( -- )
    maybe-download read-model <bunny-gadget>
    "Bunny" open-window ;