factor/extra/game/models/obj/obj.factor

! Copyright (C) 2010 Erik Charlebois
! See http://factorcode.org/license.txt for BSD license.
USING: io io.encodings.ascii math.parser sequences splitting kernel
assocs io.files combinators math.order math namespaces
arrays sequences.deep accessors
specialized-arrays.instances.alien.c-types.float
specialized-arrays.instances.alien.c-types.uint
game.models game.models.util gpu.shaders images
game.models.loader prettyprint ;
IN: game.models.obj

SINGLETON: obj-models
"obj" ascii obj-models register-models-class

<PRIVATE
SYMBOLS: vp vt vn current-model current-material material-dictionary models ;

TUPLE: material
    { name                     initial: f }
    { ambient-reflectivity     initial: { 1.0 1.0 1.0 } }
    { diffuse-reflectivity     initial: { 1.0 1.0 1.0 } }
    { specular-reflectivity    initial: { 1.0 1.0 1.0 } }
    { transmission-filter      initial: { 1.0 1.0 1.0 } }
    { dissolve                 initial: 1.0 }
    { specular-exponent        initial: 10.0 }
    { refraction-index         initial: 1.5 }
    { ambient-map              initial: f }
    { diffuse-map              initial: f }
    { specular-map             initial: f }
    { specular-exponent-map    initial: f }
    { dissolve-map             initial: f }
    { displacement-map         initial: f }
    { bump-map                 initial: f }
    { reflection-map           initial: f } ;

: cm ( -- current-material ) current-material get ; inline
: md ( -- material-dictionary ) material-dictionary get ; inline

: strings>floats ( strings -- floats )
    [ string>float ] map ;

: strings>faces ( strings -- faces )
    [ "/" split [ string>number ] map ] map ;

: split-string ( string -- strings )
    " \t\n" split harvest ;

: line>mtl ( line -- )
    " \t\n" split harvest
    [
        [ rest ] [ first ] bi
        {
            { "newmtl" [ first
                [ material new swap >>name current-material set ]
                [ cm swap md set-at ] bi
            ] }
            { "Ka"       [ 3 head [ string>float ] map cm (>>ambient-reflectivity)  ] }
            { "Kd"       [ 3 head [ string>float ] map cm (>>diffuse-reflectivity)  ] }
            { "Ks"       [ 3 head [ string>float ] map cm (>>specular-reflectivity) ] }
            { "Tf"       [ 3 head [ string>float ] map cm (>>transmission-filter)   ] }
            { "d"        [ first string>float cm          (>>dissolve)              ] }
            { "Ns"       [ first string>float cm          (>>specular-exponent)     ] }
            { "Ni"       [ first string>float cm          (>>refraction-index)      ] }
            { "map_Ka"   [ first cm                       (>>ambient-map)           ] }
            { "map_Kd"   [ first cm                       (>>diffuse-map)           ] }
            { "map_Ks"   [ first cm                       (>>specular-map)          ] }
            { "map_Ns"   [ first cm                       (>>specular-exponent-map) ] }
            { "map_d"    [ first cm                       (>>dissolve-map)          ] }
            { "map_bump" [ first cm                       (>>bump-map)              ] }
            { "bump"     [ first cm                       (>>bump-map)              ] }
            { "disp"     [ first cm                       (>>displacement-map)      ] }
            { "refl"     [ first cm                       (>>reflection-map)        ] }
            [ 2drop ]
        } case
    ] unless-empty ;

: read-mtl ( file -- material-dictionary )
    [
        f current-material set
        H{ } clone material-dictionary set
    ] H{ } make-assoc
    [
        ascii file-lines [ line>mtl ] each
        md
    ] bind ;

VERTEX-FORMAT: obj-vertex-format
    { "POSITION" float-components 3 f }
    { "TEXCOORD" float-components 2 f }
    { "NORMAL"   float-components 3 f } ;

: triangle>aos ( x -- y )
    dup length
    {
        { 3 [
            first3
            [ 1 - vp get nth ]
            [ 1 - vt get nth ]
            [ 1 - vn get nth ] tri* 3array flatten
        ] }
        { 2 [
            first2
            [ 1 - vp get nth ]
            [ 1 - vt get nth ] bi* 2array flatten
        ] }
    } case ;
          
: quad>aos ( x -- y z )
    [ 3 head [ triangle>aos 1array ] map ]
    [ [ 2 swap nth ]
      [ 3 swap nth ]
      [ 0 swap nth ] tri 3array
      [ triangle>aos 1array ] map ]
    bi ;

: face>aos ( x -- y )
    dup length
    {
        { 3 [ [ triangle>aos 1array ] map 1array ] }
        { 4 [ quad>aos 2array ] }
    } case ;

: push* ( elt seq -- seq )
    [ push ] keep ;

: push-current-model ( -- )
    current-model get [
        [ dseq>> flatten >float-array ]
        [ iseq>> flatten >uint-array ]
        bi obj-vertex-format current-material get model boa models get push
        V{ } V{ } H{ } <indexed-seq> current-model set
    ] unless-empty ;

: line>obj ( line -- )
    split-string
    [
        [ rest ] [ first ] bi
        {
            { "mtllib" [ first read-mtl material-dictionary set ] }
            { "v"      [ strings>floats 3 head vp [ push* ] change ] }
            { "vt"     [ strings>floats 2 head vt [ push* ] change ] }
            { "vn"     [ strings>floats 3 head vn [ push* ] change ] }
            { "usemtl" [ push-current-model first md at current-material set ] }
            { "f"      [ strings>faces face>aos [ [ current-model [ push* ] change ] each ] each ] }
            [ 2drop ]
        } case
    ] unless-empty ;

PRIVATE>

M: obj-models stream>models
    drop
    [
        V{ } clone vp set
        V{ } clone vt set
        V{ } clone vn set
        V{ } clone models set
        V{ } V{ } H{ } <indexed-seq> current-model set
        f current-material set
        f material-dictionary set
    ] H{ } make-assoc 
    [
        [ line>obj ] each-stream-line push-current-model
        models get
    ] bind ;