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 assocs combinators kernel make math
   4 math.vectors random sequences sets sorting ;
   5
   6 IN: snake-game.game
   7
   8 SYMBOLS: :left :right :up :down ;
   9
  10 SYMBOLS: :head :body :tail ;
  11
  12 CONSTANT: snake-game-dim { 12 10 }
  13
  14 TUPLE: snake-game
  15     snake snake-loc snake-dir food-loc
  16     { next-turn-dir initial: f }
  17     { score integer initial: 0 }
  18     { paused? boolean initial: t }
  19     { game-over? boolean initial: f } ;
  20
  21 TUPLE: snake-part
  22     dir type ;
  23
  24 C: <snake-part> snake-part
  25
  26 : <snake> ( -- snake )
  27     [
  28         :left :head <snake-part> ,
  29         :left :body <snake-part> ,
  30         :left :tail <snake-part> ,
  31     ] V{ } make ;
  32
  33 : <snake-game> ( -- snake-game )
  34     snake-game new
  35         <snake> >>snake
  36         { 5 4 } clone >>snake-loc
  37         :right >>snake-dir
  38         { 1 1 } clone >>food-loc ;
  39
  40 : ?roll-over ( x max -- x )
  41     {
  42         { [ 2dup >= ] [ 2drop 0 ] }
  43         { [ over neg? ] [ nip 1 - ] }
  44         [ drop ]
  45     } cond ;
  46
  47 : move-loc ( loc dir -- loc )
  48     H{
  49         { :left  { -1  0 } }
  50         { :right {  1  0 } }
  51         { :up    {  0 -1 } }
  52         { :down  {  0  1 } }
  53     } at v+ snake-game-dim [ ?roll-over ] 2map ;
  54
  55 : opposite-dir ( dir -- dir )
  56     H{
  57         { :left  :right }
  58         { :right :left }
  59         { :up    :down }
  60         { :down  :up }
  61     } at ;
  62
  63 : game-loc>index ( loc -- n )
  64     first2 snake-game-dim first * + ;
  65
  66 : index>game-loc ( n -- loc )
  67     snake-game-dim first /mod swap 2array ;
  68
  69 : grow-snake ( snake dir -- snake )
  70     opposite-dir :head <snake-part> prefix
  71     dup second :body >>type drop ;
  72
  73 : move-snake ( snake dir -- snake )
  74     [ dup but-last [ dir>> ] map ] dip
  75     opposite-dir prefix [ >>dir ] 2map ;
  76
  77 : all-indices ( -- points )
  78     snake-game-dim product <iota> ;
  79
  80 : snake-occupied-locs ( snake head-loc -- points )
  81     [ dir>> move-loc ] accumulate nip ;
  82
  83 : snake-occupied-indices ( snake head-loc -- points )
  84     snake-occupied-locs [ game-loc>index ] map natural-sort ;
  85
  86 : snake-unoccupied-indices ( snake head-loc -- points )
  87     [ all-indices ] 2dip snake-occupied-indices without ;
  88
  89 : snake-will-eat-food? ( snake-game -- ? )
  90     [ food-loc>> ] [ snake-loc>> ] [ snake-dir>> ] tri move-loc = ;
  91
  92 : increase-score ( snake-game -- snake-game )
  93     [ 1 + ] change-score ;
  94
  95 : update-snake-shape ( snake-game growing? -- snake-game )
  96     [ dup snake-dir>> ] dip
  97     '[ _ _ [ grow-snake ] [ move-snake ] if ] change-snake ;
  98
  99 : update-snake-loc ( snake-game -- snake-game )
 100     dup snake-dir>> '[ _ move-loc ] change-snake-loc ;
 101
 102 : generate-food ( snake-game -- snake-game )
 103     dup [ snake>> ] [ snake-loc>> ] bi
 104     snake-unoccupied-indices random index>game-loc
 105     >>food-loc ;
 106
 107 : game-in-progress? ( snake-game -- ? )
 108     [ game-over?>> ] [ paused?>> ] bi or not ;
 109
 110 : ?handle-pending-turn ( snake-game -- )
 111     dup next-turn-dir>> [
 112         >>snake-dir
 113         f >>next-turn-dir
 114     ] when* drop ;
 115
 116 : snake-will-eat-itself? ( snake-game -- ? )
 117     [ snake>> ] [ snake-loc>> ] [ snake-dir>> ] tri move-loc
 118     [ snake-occupied-locs rest ] keep swap member? ;
 119
 120 : game-over ( snake-game -- )
 121     t >>game-over? drop ;
 122
 123 : update-snake ( snake-game -- )
 124     dup snake-will-eat-food? {
 125         [ [ increase-score ] when ]
 126         [ update-snake-shape ]
 127         [ drop update-snake-loc ]
 128         [ [ generate-food ] when ]
 129     } cleave drop ;
 130
 131 : do-game-step ( snake-game -- )
 132     dup game-in-progress? [
 133         dup ?handle-pending-turn
 134         dup snake-will-eat-itself?
 135         [ game-over ] [ update-snake ] if
 136     ] [ drop ] if ;