extra/gamelib/demos/sokoban/sokoban.factor

   1 USING: literals kernel namespaces accessors sequences
   2 combinators math.vectors colors gamelib.ui gamelib.board
   3 gamelib.cell-object gamelib.loop game.loop ui.gestures
   4 ui.gadgets opengl opengl.textures images.loader prettyprint
   5 layouts gamelib.demos.sokoban.layouts gamelib.demos.sokoban.loop ;
   6
   7 IN: gamelib.demos.sokoban
   8
   9 CONSTANT: player "vocab:gamelib/demos/sokoban/resources/CharR.png"
  10 CONSTANT: wall "vocab:gamelib/demos/sokoban/resources/Wall_Brown.png"
  11 CONSTANT: goal "vocab:gamelib/demos/sokoban/resources/Goal.png"
  12 CONSTANT: light-crate "vocab:gamelib/demos/sokoban/resources/Crate_Yellow.png"
  13 CONSTANT: dark-crate "vocab:gamelib/demos/sokoban/resources/CrateDark_Yellow.png"
  14
  15 :: move-crate ( board player-pos move crate -- )
  16     player-pos move v+ :> crate-pos
  17     board crate-pos move v+ get-cell :> next-cell
  18     ! Move both the player and crate if possible, otherwise do nothing
  19     {
  20         {
  21             [ next-cell is-empty? ] ! crate can be moved to free space
  22             [ crate light-crate >>image-path drop
  23             board crate-pos move crate move-object
  24             player-pos move player move-object drop ]
  25         }
  26         {
  27             [ next-cell goal cell-only-contains? ] ! crate can be moved to goal
  28             [ crate dark-crate >>image-path drop
  29             board crate-pos move crate move-object
  30             player-pos move player move-object drop ]
  31         }
  32         [ ] ! Else do nothing
  33     } cond ;
  34
  35 :: sokoban-move ( board move -- )
  36     board [ player = ] find-cell-pos :> player-pos
  37     player-pos move v+ :> new-pos
  38     board new-pos get-cell :> adjacent-cell
  39     ! Move player to free space or have player push crate if possible, otherwise do nothing
  40     {
  41         {
  42             [ adjacent-cell crate-cell cell-contains-instance? ] ! player is moving into a crate
  43             [ adjacent-cell crate-cell get-instance-from-cell :> crate
  44             board player-pos move crate move-crate ]
  45         }
  46         {
  47             [ adjacent-cell is-empty? adjacent-cell goal cell-contains? or ] ! player can be moved to free space or goal
  48             [ board player-pos move player move-object drop ]
  49         }
  50         [ ] ! Else do nothing
  51     } cond ;
  52
  53 : game-logic ( gadget -- gadget )
  54     ! Move pieces according to user input
  55     T{ key-down f f "UP" } [ board>> first UP sokoban-move ] new-gesture
  56     T{ key-down f f "DOWN" } [ board>> first DOWN sokoban-move ] new-gesture
  57     T{ key-down f f "RIGHT" } [ board>> first RIGHT sokoban-move ] new-gesture
  58     T{ key-down f f "LEFT" } [ board>> first LEFT sokoban-move ] new-gesture ;
  59
  60 : main ( -- )
  61     [ 0 level set-global ] with-global ! set global level variable to 0
  62     { 600 675 } init-board-gadget
  63     board-one
  64     <game-state> create-loop
  65     game-logic
  66     display ;
  67
  68 MAIN: main