extra/game/models/obj/obj.factor

   1 ! Copyright (C) 2010 Erik Charlebois
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: io io.encodings.ascii math.parser sequences splitting
   4 kernel assocs io.files combinators math.order math namespaces
   5 arrays sequences.deep accessors alien.c-types alien.data
   6 game.models game.models.util gpu.shaders images game.models.loader
   7 prettyprint specialized-arrays ;
   8 QUALIFIED-WITH: alien.c-types c
   9 SPECIALIZED-ARRAYS: c:float c:uint ;
  10 IN: game.models.obj
  11
  12 SINGLETON: obj-models
  13 "obj" ascii obj-models register-models-class
  14
  15 <PRIVATE
  16 SYMBOLS: vp vt vn current-model current-material material-dictionary models ;
  17
  18 TUPLE: material
  19     { name                     initial: f }
  20     { ambient-reflectivity     initial: { 1.0 1.0 1.0 } }
  21     { diffuse-reflectivity     initial: { 1.0 1.0 1.0 } }
  22     { specular-reflectivity    initial: { 1.0 1.0 1.0 } }
  23     { transmission-filter      initial: { 1.0 1.0 1.0 } }
  24     { dissolve                 initial: 1.0 }
  25     { specular-exponent        initial: 10.0 }
  26     { refraction-index         initial: 1.5 }
  27     { ambient-map              initial: f }
  28     { diffuse-map              initial: f }
  29     { specular-map             initial: f }
  30     { specular-exponent-map    initial: f }
  31     { dissolve-map             initial: f }
  32     { displacement-map         initial: f }
  33     { bump-map                 initial: f }
  34     { reflection-map           initial: f } ;
  35
  36 : cm ( -- current-material ) current-material get ; inline
  37 : md ( -- material-dictionary ) material-dictionary get ; inline
  38
  39 : strings>numbers ( strings -- numbers )
  40     [ string>number ] map ;
  41
  42 : strings>faces ( strings -- faces )
  43     [ "/" split [ string>number ] map ] map ;
  44
  45 : split-string ( string -- strings )
  46     " \t\n" split harvest ;
  47
  48 : line>mtl ( line -- )
  49     " \t\n" split harvest
  50     [
  51         [ rest ] [ first ] bi
  52         {
  53             { "newmtl" [ first
  54                 [ material new swap >>name current-material set ]
  55                 [ cm swap md set-at ] bi
  56             ] }
  57             { "Ka"       [ 3 head strings>numbers cm ambient-reflectivity<<  ] }
  58             { "Kd"       [ 3 head strings>numbers cm diffuse-reflectivity<<  ] }
  59             { "Ks"       [ 3 head strings>numbers cm specular-reflectivity<< ] }
  60             { "Tf"       [ 3 head strings>numbers cm transmission-filter<<   ] }
  61             { "d"        [ first string>number cm    dissolve<<              ] }
  62             { "Ns"       [ first string>number cm    specular-exponent<<     ] }
  63             { "Ni"       [ first string>number cm    refraction-index<<      ] }
  64             { "map_Ka"   [ first cm                  ambient-map<<           ] }
  65             { "map_Kd"   [ first cm                  diffuse-map<<           ] }
  66             { "map_Ks"   [ first cm                  specular-map<<          ] }
  67             { "map_Ns"   [ first cm                  specular-exponent-map<< ] }
  68             { "map_d"    [ first cm                  dissolve-map<<          ] }
  69             { "map_bump" [ first cm                  bump-map<<              ] }
  70             { "bump"     [ first cm                  bump-map<<              ] }
  71             { "disp"     [ first cm                  displacement-map<<      ] }
  72             { "refl"     [ first cm                  reflection-map<<        ] }
  73             [ 2drop ]
  74         } case
  75     ] unless-empty ;
  76
  77 : read-mtl ( file -- material-dictionary )
  78     [
  79         f current-material set
  80         H{ } clone material-dictionary set
  81     ] H{ } make-assoc
  82     [
  83         ascii file-lines [ line>mtl ] each
  84         md
  85     ] bind ;
  86
  87 VERTEX-FORMAT: obj-vertex-format
  88     { "POSITION" float-components 3 f }
  89     { "TEXCOORD" float-components 2 f }
  90     { "NORMAL"   float-components 3 f } ;
  91
  92 : triangle>aos ( x -- y )
  93     dup length
  94     {
  95         { 3 [
  96             first3
  97             [ 1 - vp get nth ]
  98             [ 1 - vt get nth ]
  99             [ 1 - vn get nth ] tri* 3array flatten
 100         ] }
 101         { 2 [
 102             first2
 103             [ 1 - vp get nth ]
 104             [ 1 - vt get nth ] bi* 2array flatten
 105         ] }
 106     } case ;
 107
 108 : quad>aos ( x -- y z )
 109     [ 3 head [ triangle>aos 1array ] map ]
 110     [ [ 2 swap nth ]
 111       [ 3 swap nth ]
 112       [ 0 swap nth ] tri 3array
 113       [ triangle>aos 1array ] map ]
 114     bi ;
 115
 116 : face>aos ( x -- y )
 117     dup length
 118     {
 119         { 3 [ [ triangle>aos 1array ] map 1array ] }
 120         { 4 [ quad>aos 2array ] }
 121     } case ;
 122
 123 : push* ( elt seq -- seq )
 124     [ push ] keep ;
 125
 126 : push-current-model ( -- )
 127     current-model get [
 128         [ dseq>> flatten c:float >c-array ]
 129         [ iseq>> flatten c:uint >c-array ]
 130         bi obj-vertex-format current-material get model boa models get push
 131         V{ } V{ } H{ } <indexed-seq> current-model set
 132     ] unless-empty ;
 133
 134 : line>obj ( line -- )
 135     split-string
 136     [
 137         [ rest ] [ first ] bi
 138         {
 139             { "mtllib" [ first read-mtl material-dictionary set ] }
 140             { "v"      [ strings>numbers 3 head vp [ push* ] change ] }
 141             { "vt"     [ strings>numbers 2 head vt [ push* ] change ] }
 142             { "vn"     [ strings>numbers 3 head vn [ push* ] change ] }
 143             { "usemtl" [ push-current-model first md at current-material set ] }
 144             { "f"      [ strings>faces face>aos [ [ current-model [ push* ] change ] each ] each ] }
 145             [ 2drop ]
 146         } case
 147     ] unless-empty ;
 148
 149 PRIVATE>
 150
 151 M: obj-models stream>models
 152     drop
 153     [
 154         V{ } clone vp set
 155         V{ } clone vt set
 156         V{ } clone vn set
 157         V{ } clone models set
 158         V{ } V{ } H{ } <indexed-seq> current-model set
 159         f current-material set
 160         f material-dictionary set
 161     ] H{ } make-assoc
 162     [
 163         [ line>obj ] each-stream-line push-current-model
 164         models get
 165     ] bind ;
 166