extra/snake-game/game/game.factor

   1 ! Copyright (C) 2015 Sankaranarayanan Viswanathan.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators kernel make math random
   4 sequences sets snake-game.constants snake-game.util sorting ;
   5
   6 IN: snake-game.game
   7
   8 TUPLE: snake-game
   9     snake snake-loc snake-dir food-loc
  10     { next-turn-dir initial: f }
  11     { score integer initial: 0 }
  12     { paused? boolean initial: t }
  13     { game-over? boolean initial: f } ;
  14
  15 TUPLE: snake-part
  16     dir type ;
  17
  18 C: <snake-part> snake-part
  19
  20 : <snake> ( -- snake )
  21     [
  22         :left :head <snake-part> ,
  23         :left :body <snake-part> ,
  24         :left :tail <snake-part> ,
  25     ] V{ } make ;
  26
  27 : <snake-game> ( -- snake-game )
  28     snake-game new
  29     <snake> >>snake
  30     { 5 4 } clone >>snake-loc
  31     :right >>snake-dir
  32     { 1 1 } clone >>food-loc ;
  33
  34 : game-loc>index ( loc -- n )
  35     first2 snake-game-dim first * + ;
  36
  37 : index>game-loc ( n -- loc )
  38     snake-game-dim first /mod swap 2array ;
  39
  40 : snake-shape ( snake -- dirs )
  41     [ dir>> ] map ;
  42
  43 : grow-snake ( snake dir -- snake )
  44     opposite-dir :head <snake-part> prefix
  45     dup second :body >>type drop ;
  46
  47 : move-snake ( snake dir -- snake )
  48     dupd [ snake-shape but-last ] dip
  49     opposite-dir prefix [ >>dir ] 2map ;
  50
  51 : all-indices ( -- points )
  52     snake-game-dim first2 * <iota> ;
  53
  54 : snake-occupied-locs ( snake head-loc -- points )
  55     [ dir>> relative-loc ] accumulate nip ;
  56
  57 : snake-occupied-indices ( snake head-loc -- points )
  58     snake-occupied-locs [ game-loc>index ] map natural-sort ;
  59
  60 : snake-unoccupied-indices ( snake head-loc -- points )
  61     [ all-indices ] 2dip snake-occupied-indices without ;
  62
  63 : snake-will-eat-food? ( snake-game dir -- ? )
  64     [ [ food-loc>> ] [ snake-loc>> ] bi ] dip
  65     relative-loc = ;
  66
  67 : update-score ( snake-game -- )
  68     [ 1 + ] change-score
  69     drop ;
  70
  71 : update-snake-shape ( snake-game dir growing? -- )
  72     [ [ grow-snake ] curry change-snake ]
  73     [ [ move-snake ] curry change-snake ]
  74     if drop ;
  75
  76 : update-snake-loc ( snake-game dir -- )
  77     [ relative-loc ] curry change-snake-loc drop ;
  78
  79 : update-snake-dir ( snake-game dir -- )
  80     >>snake-dir drop ;
  81
  82 : generate-food ( snake-game -- )
  83     [
  84         [ snake>> ] [ snake-loc>> ] bi
  85         snake-unoccupied-indices random index>game-loc
  86     ] keep food-loc<< ;
  87
  88 : game-in-progress? ( snake-game -- ? )
  89     [ game-over?>> ] [ paused?>> ] bi or not ;
  90
  91 : ?handle-pending-turn ( snake-game -- )
  92     dup next-turn-dir>> [
  93         >>snake-dir
  94         f >>next-turn-dir
  95     ] when* drop ;
  96
  97 : snake-will-eat-itself? ( snake-game dir -- ? )
  98     [ [ snake>> ] [ snake-loc>> ] bi ] dip relative-loc
  99     [ snake-occupied-locs rest ] keep
 100     swap member? ;
 101
 102 : game-over ( snake-game -- )
 103     t >>game-over? drop ;
 104
 105 : update-snake ( snake-game dir -- )
 106     2dup snake-will-eat-food?
 107     {
 108         [ [ drop update-score ] [ 2drop ] if ]
 109         [ update-snake-shape ]
 110         [ drop update-snake-loc ]
 111         [ drop update-snake-dir ]
 112         [ nip [ generate-food ] [ drop ] if ]
 113     } 3cleave ;
 114
 115 : do-game-step ( snake-game -- )
 116     dup game-in-progress? [
 117         dup ?handle-pending-turn
 118         dup snake-dir>>
 119         2dup snake-will-eat-itself?
 120         [ drop game-over ] [ update-snake ] if
 121     ] [ drop ] if ;