extra/snake-game/sprites/sprites.factor

   1 ! Copyright (C) 2015 Sankaranarayanan Viswanathan.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs byte-vectors formatting fry
   4 images images.loader kernel locals make math math.vectors
   5 opengl.textures sequences ;
   6
   7 IN: snake-game.sprites
   8
   9 : new-image-like ( image w h -- image )
  10     [ clone ] 2dip
  11     [ 2array >>dim ] 2keep *
  12     over bytes-per-pixel * <byte-vector> >>bitmap ;
  13
  14 :: image-part ( image x y w h -- image )
  15     image w h new-image-like :> new-image
  16     h <iota> [| i |
  17         new-image bitmap>>
  18         x y i + w image pixel-row-slice-at
  19         append! drop
  20     ] each new-image ;
  21
  22 :: generate-sprite-sheet ( image rows cols -- seq )
  23     cols rows 2array :> split-dims
  24     image dim>> split-dims [ / ] 2map first2 :> ( sw sh )
  25     rows <iota> sh v*n :> ys
  26     cols <iota> sh v*n :> xs
  27     ys xs [
  28         swap [ image ] 2dip sw sh image-part
  29     ] cartesian-map f join ;
  30
  31 : load-sprite-image ( filename -- image )
  32     "vocab:snake-game/_resources/%s" sprintf load-image ;
  33
  34 : make-texture ( image -- texture )
  35     { 0 0 } <texture> ;
  36
  37 : make-sprites ( filename cols rows -- seq )
  38     [ load-sprite-image ] 2dip generate-sprite-sheet
  39     [ make-texture ] map ;
  40
  41 : snake-head-textures ( -- assoc )
  42     "head.png" 1 4 make-sprites
  43     { "head-up" "head-right" "head-down" "head-left" }
  44     [ swap 2array ] 2map ;
  45
  46 :: assoc-with-value-like ( assoc key seq -- )
  47     key assoc at :> value
  48     seq [ [ value ] dip assoc set-at ] each ;
  49
  50 : snake-body-textures ( -- assoc )
  51     "body.png" 3 2 make-sprites
  52     { 1 2 3 4 5 6 }
  53     [ swap 2array ] 2map
  54     dup 1 { "body-right-up" "body-down-left" } assoc-with-value-like
  55     dup 2 { "body-down-right" "body-left-up" } assoc-with-value-like
  56     dup 3 { "body-right-right" "body-left-left" } assoc-with-value-like
  57     dup 4 { "body-up-up" "body-down-down" } assoc-with-value-like
  58     dup 5 { "body-up-right" "body-left-down" } assoc-with-value-like
  59     dup 6 { "body-right-down" "body-up-left" } assoc-with-value-like
  60     dup [ { 1 2 3 4 5 6 } ] dip [ delete-at ] curry each ;
  61
  62 : snake-tail-textures ( -- assoc )
  63     "tail.png" 2 2 make-sprites
  64     { "tail-down" "tail-left" "tail-up" "tail-right" }
  65     [ swap 2array ] 2map ;
  66
  67 : food-texture ( -- assoc )
  68     "food" "food.png" load-sprite-image make-texture
  69     2array 1array ;
  70
  71 : background-texture ( -- assoc )
  72     "background" "background.png" load-sprite-image make-texture
  73     2array 1array ;