extra/papier/map/map.factor

   1 ! (c)2010 Joe Groff bsd license
   2 USING: accessors alien assocs classes.struct combinators
   3 combinators.short-circuit fry gpu.shaders images images.atlas
   4 images.loader io.directories io.encodings.utf8 io.files
   5 io.pathnames json json.reader kernel locals math math.matrices.simd
   6 math.vectors.simd sequences sets specialized-arrays
   7 strings typed ;
   8 FROM: alien.c-types => float ;
   9 SPECIALIZED-ARRAYS: float float-4 ;
  10 IN: papier.map
  11
  12 ERROR: bad-papier-version version ;
  13
  14 CONSTANT: papier-map-version 3
  15
  16 : check-papier-version ( hash -- hash )
  17     "papier" over at dup papier-map-version = [ drop ] [ bad-papier-version ] if ;
  18
  19 UNION: ?string string POSTPONE: f ;
  20
  21 TUPLE: slab
  22     { name ?string }
  23     images
  24     { frame fixnum }
  25     { center float-4 }
  26     { size float-4 }
  27     { orient float-4 }
  28     { color float-4 }
  29
  30     { matrix matrix4 }
  31     { texcoords float-4-array } ;
  32
  33 VERTEX-FORMAT: papier-vertex
  34     { "vertex"   float-components 3 f }
  35     { f          float-components 1 f }
  36     { "texcoord" float-components 2 f }
  37     { f          float-components 2 f }
  38     { "color"    float-components 4 f } ;
  39 STRUCT: papier-vertex-struct
  40     { vertex   float-4 }
  41     { texcoord float-4 }
  42     { color    float-4 } ;
  43 SPECIALIZED-ARRAY: papier-vertex-struct
  44
  45 ERROR: bad-matrix-dim matrix ;
  46
  47 : parse-slab ( hash -- name images frame center size orient color )
  48     {
  49         [ "name"   swap at [ f ] when-json-null ]
  50         [ "images" swap at ]
  51         [ "frame"  swap at >fixnum ]
  52         [ "center" swap at 3 0.0 pad-tail 4 1.0 pad-tail >float-4 ]
  53         [ "size"   swap at                4 1.0 pad-tail >float-4 ]
  54         [ "orient" swap at                               >float-4 ]
  55         [ "color"  swap at                               >float-4 ]
  56     } cleave ;
  57
  58 TYPED: slab-matrix ( slab: slab -- matrix: matrix4 )
  59     [ center>> translation-matrix4 ]
  60     [ size>> scale-matrix4 m4. ]
  61     [ orient>> q>matrix4 m4. ] tri ;
  62
  63 TYPED: update-slab-matrix ( slab: slab -- )
  64     dup slab-matrix >>matrix drop ;
  65
  66 TYPED: cycle-slab-frame ( slab: slab -- )
  67     dup images>> length '[ 1 + dup _ < [ drop 0 ] unless ] change-frame drop ;
  68
  69 : <slab> ( -- slab ) slab new ; inline
  70
  71 : set-up-slab ( name images frame center size orient color slab -- slab )
  72     swap >>color
  73     swap >>orient
  74     swap >>size
  75     swap >>center
  76     swap >>frame
  77     swap >>images
  78     swap >>name
  79     dup update-slab-matrix ; inline
  80
  81 TYPED: update-slab-for-atlas ( slab: slab images -- )
  82     [ dup images>> ] dip '[ _ at >float-4 ] float-4-array{ } map-as >>texcoords drop ;
  83
  84 : update-slabs-for-atlas ( slabs images -- )
  85     '[ _ update-slab-for-atlas ] each ; inline
  86
  87 : parse-papier-map ( hash -- slabs )
  88     check-papier-version
  89     "slabs" swap at [ parse-slab <slab> set-up-slab ] map ;
  90
  91 : load-papier-map ( path name -- slabs )
  92     append-path utf8 file-contents json> parse-papier-map ;
  93
  94 : load-papier-images ( path -- images atlas )
  95     [
  96         [ file-extension { "tiff" "png" } member? ] filter [ dup load-image ] H{ } map>assoc
  97     ] with-directory-files make-atlas-assoc ;
  98
  99 : slabs-by-name ( slabs -- assoc )
 100     [ name>> ] filter [ [ name>> ] keep ] H{ } map>assoc ; inline