extra/sokoban/game/game.factor

   1 ! Copyright (C) 2006, 2007, 2008 Alex Chapman
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: accessors combinators kernel lists math math.functions math.vectors
   5 sequences system sokoban.board sokoban.piece sokoban.layout sokoban.sound colors
   6 namespaces locals ;
   7
   8 IN: sokoban.game
   9
  10 TUPLE: sokoban
  11     { board }
  12     { player }
  13     { boxes }
  14     { goals }
  15     { engine }
  16     { last-update integer initial: 0 }
  17     { level integer initial: 0 }
  18     { paused? initial: f }
  19     { running? initial: t } ;
  20
  21 : add-wall-block ( sokoban block -- )
  22     over [ board>> ] 2dip <board-piece> swap level>> rotate-piece layout>> color>> set-block ;
  23
  24 : add-walls ( sokoban -- )
  25     dup <board-piece> swap level>> rotate-piece wall-blocks [ add-wall-block ] with each ;
  26
  27 :: <sokoban> ( lev w h -- sokoban )
  28     ! make components
  29     w h <board> :> board
  30     lev <player-piece> :> player
  31     lev <goal-piece> :> goals
  32
  33     ! put components into sokoban instance
  34     sokoban new :> soko
  35     soko player >>player
  36     lev >>level
  37     board >>board
  38     goals >>goals
  39     goals lev <box-seq> >>boxes
  40     soko add-walls ; ! draw walls
  41
  42
  43 : <default-sokoban> ( -- sokoban )
  44     ! Level 0 sokoban
  45     0 8 9 <sokoban> ;
  46
  47 : toggle-pause ( sokoban -- )
  48     [ not ] change-paused? drop ;
  49
  50 : can-player-move? ( sokoban move -- ? )
  51     [ drop board>> ] [ [ player>> clone ] dip move-piece ] 2bi piece-valid? ;
  52
  53 :: get-adj-box ( soko piece mov -- box )
  54     ! If the input piece (either a player or another box) has a box at its move location,
  55     ! return the box at the move location. Otherwise, return false
  56     piece location>> :> player_loc
  57     player_loc mov v+ :> next_loc
  58     soko boxes>> :> box_list
  59     box_list [ location>> next_loc = ] find swap drop ;
  60
  61 :: can-box-move? ( soko box mov -- ? )
  62     soko box mov get-adj-box :> box2move ! Checks if input box has a box at its move location
  63     box2move
  64     [   ! If there is another box at the move location, the current box is unable to move
  65         f
  66     ]
  67     [   ! Otherwise, we check if there is a wall blocking the box
  68         soko board>> box clone mov move-piece piece-valid?
  69     ] if ;
  70
  71 :: sokoban-move ( soko mov -- ? )
  72     ! Collision logic -- checks if player can move and moves the player accordingly
  73     soko mov can-player-move?
  74     [   ! Player can move
  75         soko dup player>> mov get-adj-box :> box2move
  76         box2move
  77         [   ! Next location of player is a box
  78             soko box2move mov can-box-move?
  79             [   ! Next location of player is a box and box is able to move
  80                 soko goals>> box2move location>> mov is-goal?
  81                 [   ! Next location of box is a goal point
  82                     soko player>> mov move-piece drop
  83                     box2move mov move-piece
  84                     soko engine>> play-beep
  85                     "vocab:sokoban/resources/CrateDark_Yellow.png" >>path
  86                     layout>> COLOR: blue >>color drop t ! change color once box is on goal
  87                 ]
  88                 [   ! Next location of box is a free space
  89                     soko player>> mov move-piece drop
  90                     box2move mov move-piece
  91                     layout>> COLOR: orange >>color drop t
  92                 ] if
  93             ]
  94             [   ! Next location of player is a box but box cannot move
  95                 f
  96             ] if
  97         ]
  98         [   ! Next location of player is a free space, move the player onto the free space
  99             soko player>> mov move-piece drop t
 100         ] if
 101     ]
 102     [   ! Player cannot move
 103         f
 104     ] if ;
 105
 106 : move-left ( sokoban -- ) dup player>> "vocab:sokoban/resources/CharL.png" >>path drop { -1 0 } sokoban-move drop ;
 107
 108 : move-right ( sokoban -- ) dup player>> "vocab:sokoban/resources/CharR.png" >>path drop { 1 0 } sokoban-move drop ;
 109
 110 : move-down ( sokoban -- ) dup player>> "vocab:sokoban/resources/CharF.png" >>path drop { 0 1 } sokoban-move drop ;
 111
 112 : move-up ( sokoban -- ) dup player>> "vocab:sokoban/resources/CharB.png" >>path drop { 0 -1 } sokoban-move drop ;
 113
 114 : update-level? ( sokoban -- ? )
 115     ! Get color color of each box
 116     boxes>> [ layout>> ] map [ color>> ] map
 117     ! All boxes are on correct spots if there are no orange boxes left and level should be updated
 118     [ COLOR: orange ] first swap member? not ;
 119