+++ /dev/null
-This is a simple sokoban game. To play, open factor (in GUI mode), and run:
-
-"sokoban" run
-
-This should open a new window with a running sokoban game. The commands are:
-
-left,right,up,down arrows -- moves the player in the given direction
+++ /dev/null
-Factor Clinic Team 2021-2022
+++ /dev/null
-USING: accessors arrays colors kernel sokoban.board sokoban.piece tools.test ;
-
-{ { { f f } { f f } { f f } } } [ 2 3 make-rows ] unit-test
-{ { { f f } { f f } { f f } } } [ 2 3 <board> rows>> ] unit-test
-{ 1 { f f } } [ 2 3 <board> { 1 1 } board@block ] unit-test
-{ f } [ 2 3 <board> { 1 1 } block ] unit-test
-[ 2 3 <board> { 2 3 } block ] must-fail
-{ COLOR: red } [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 1 } block ] unit-test
-{ t } [ 2 3 <board> { 1 1 } block-free? ] unit-test
-{ f } [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 1 } block-free? ] unit-test
-{ t } [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 2 } block-free? ] unit-test
-{ t } [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 0 1 } block-free? ] unit-test
-{ t } [ 2 3 <board> { 0 0 } block-in-bounds? ] unit-test
-{ f } [ 2 3 <board> { -1 0 } block-in-bounds? ] unit-test
-{ t } [ 2 3 <board> { 1 2 } block-in-bounds? ] unit-test
-{ f } [ 2 3 <board> { 2 2 } block-in-bounds? ] unit-test
-{ t } [ 2 3 <board> { 1 1 } location-valid? ] unit-test
-{ f } [ 2 3 <board> dup { 1 1 } COLOR: red set-block { 1 1 } location-valid? ] unit-test
-! { t } [ 10 10 <board> 10 <random-piece> piece-valid? ] unit-test
-! { f } [ 2 3 <board> 10 <random-piece> { 1 2 } >>location piece-valid? ] unit-test
-! { { { f } { f } } } [ 1 1 <board> add-row rows>> ] unit-test
-! { { { f } } } [ 1 2 <board> dup { 0 1 } COLOR: red set-block remove-full-rows rows>> ] unit-test
-! { { { f } { f } } } [ 1 2 <board> dup { 0 1 } COLOR: red set-block dup check-rows drop rows>> ] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators.short-circuit fry kernel
-math sequences sokoban.piece sokoban.layout ;
-IN: sokoban.board
-
-TUPLE: board
- { width integer }
- { height integer }
- { rows array } ;
-
-: make-rows ( width height -- rows )
- swap '[ _ f <array> ] replicate ;
-
-: <board> ( width height -- board )
- 2dup make-rows board boa ;
-
-! A block is simply an array of form { x y } where { 0 0 } is
-! the top-left of the sokoban board, and { 9 19 } is the bottom
-! right on a 10x20 board.
-
-: board@block ( board block -- n row )
- [ second swap rows>> nth ] keep first swap ;
-
-: set-block ( board block color -- ) -rot board@block set-nth ;
-
-: block ( board block -- color ) board@block nth ;
-
-: block-free? ( board block -- ? ) block not ;
-
-: block-in-bounds? ( board block -- ? )
- [ first swap width>> <iota> bounds-check? ]
- [ second swap height>> <iota> bounds-check? ] 2bi and ;
-
-: location-valid? ( board block -- ? )
- { [ block-in-bounds? ] [ block-free? ] } 2&& ;
-
-: piece-valid? ( board piece -- ? )
- piece-blocks [ location-valid? ] with all? ;
+++ /dev/null
-USING: tools.deploy.config ;
-H{
- { deploy-ui? t }
- { deploy-threads? t }
- { deploy-word-props? f }
- { deploy-reflection 1 }
- { "stop-after-last-window?" t }
- { deploy-io 3 }
- { deploy-math? t }
- { deploy-word-defs? f }
- { deploy-c-types? f }
- { deploy-name "sokoban" }
-}
+++ /dev/null
-USING: accessors kernel sokoban.game sokoban.board sokoban.piece tools.test
-sequences ;
-
-! { t } [ <default-sokoban> [ current-piece ] [ next-piece ] bi and t f ? ] unit-test
-! { t } [ <default-sokoban> { 1 1 } can-move? ] unit-test
-{ t } [ <default-sokoban> { 1 1 } sokoban-move ] unit-test
-! { 1 } [ <default-sokoban> dup { 1 1 } sokoban-move drop current-piece location>> second ] unit-test
-{ 0 } [ <default-sokoban> level>> ] unit-test
-! { 1 } [ <default-sokoban> 9 >>rows level>> ] unit-test
-! { 2 } [ <default-sokoban> 10 >>rows level>> ] unit-test
-! { 0 } [ 3 0 rows-score ] unit-test
-! { 80 } [ 1 1 rows-score ] unit-test
-! { 4800 } [ 3 4 rows-score ] unit-test
-! { 1 } [ <default-sokoban> dup 3 score-rows dup 3 score-rows dup 3 score-rows level ] unit-test
-! { 2 } [ <default-sokoban> dup 4 score-rows dup 4 score-rows dup 2 score-rows level ] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: accessors combinators kernel lists math math.functions math.vectors
-sequences system sokoban.board sokoban.piece sokoban.layout sokoban.sound colors
-namespaces locals ;
-
-IN: sokoban.game
-
-TUPLE: sokoban
- { board }
- { player }
- { boxes }
- { goals }
- { engine }
- { last-update integer initial: 0 }
- { level integer initial: 0 }
- { paused? initial: f }
- { running? initial: t } ;
-
-: add-wall-block ( sokoban block -- )
- over [ board>> ] 2dip <board-piece> swap level>> rotate-piece layout>> color>> set-block ;
-
-: add-walls ( sokoban -- )
- dup <board-piece> swap level>> rotate-piece wall-blocks [ add-wall-block ] with each ;
-
-:: <sokoban> ( lev w h -- sokoban )
- ! make components
- w h <board> :> board
- lev <player-piece> :> player
- lev <goal-piece> :> goals
-
- ! put components into sokoban instance
- sokoban new :> soko
- soko player >>player
- lev >>level
- board >>board
- goals >>goals
- goals lev <box-seq> >>boxes
- soko add-walls ; ! draw walls
-
-
-: <default-sokoban> ( -- sokoban )
- ! Level 0 sokoban
- 0 8 9 <sokoban> ;
-
-: toggle-pause ( sokoban -- )
- [ not ] change-paused? drop ;
-
-: can-player-move? ( sokoban move -- ? )
- [ drop board>> ] [ [ player>> clone ] dip move-piece ] 2bi piece-valid? ;
-
-:: get-adj-box ( soko piece mov -- box )
- ! If the input piece (either a player or another box) has a box at its move location,
- ! return the box at the move location. Otherwise, return false
- piece location>> :> player_loc
- player_loc mov v+ :> next_loc
- soko boxes>> :> box_list
- box_list [ location>> next_loc = ] find swap drop ;
-
-:: can-box-move? ( soko box mov -- ? )
- soko box mov get-adj-box :> box2move ! Checks if input box has a box at its move location
- box2move
- [ ! If there is another box at the move location, the current box is unable to move
- f
- ]
- [ ! Otherwise, we check if there is a wall blocking the box
- soko board>> box clone mov move-piece piece-valid?
- ] if ;
-
-:: sokoban-move ( soko mov -- ? )
- ! Collision logic -- checks if player can move and moves the player accordingly
- soko mov can-player-move?
- [ ! Player can move
- soko dup player>> mov get-adj-box :> box2move
- box2move
- [ ! Next location of player is a box
- soko box2move mov can-box-move?
- [ ! Next location of player is a box and box is able to move
- soko goals>> box2move location>> mov is-goal?
- [ ! Next location of box is a goal point
- soko player>> mov move-piece drop
- box2move mov move-piece
- soko engine>> play-beep
- "vocab:sokoban/resources/CrateDark_Yellow.png" >>path
- layout>> COLOR: blue >>color drop t ! change color once box is on goal
- ]
- [ ! Next location of box is a free space
- soko player>> mov move-piece drop
- box2move mov move-piece
- layout>> COLOR: orange >>color drop t
- ] if
- ]
- [ ! Next location of player is a box but box cannot move
- f
- ] if
- ]
- [ ! Next location of player is a free space, move the player onto the free space
- soko player>> mov move-piece drop t
- ] if
- ]
- [ ! Player cannot move
- f
- ] if ;
-
-: move-left ( sokoban -- ) dup player>> "vocab:sokoban/resources/CharL.png" >>path drop { -1 0 } sokoban-move drop ;
-
-: move-right ( sokoban -- ) dup player>> "vocab:sokoban/resources/CharR.png" >>path drop { 1 0 } sokoban-move drop ;
-
-: move-down ( sokoban -- ) dup player>> "vocab:sokoban/resources/CharF.png" >>path drop { 0 1 } sokoban-move drop ;
-
-: move-up ( sokoban -- ) dup player>> "vocab:sokoban/resources/CharB.png" >>path drop { 0 -1 } sokoban-move drop ;
-
-: update-level? ( sokoban -- ? )
- ! Get color color of each box
- boxes>> [ layout>> ] map [ color>> ] map
- ! All boxes are on correct spots if there are no orange boxes left and level should be updated
- [ COLOR: orange ] first swap member? not ;
-
+++ /dev/null
-! Copyright (C) 2006, 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays colors combinators math.vectors
-kernel math opengl opengl.gl opengl.textures sequences sokoban.game sokoban.piece images.loader
-;
-
-IN: sokoban.gl
-
-! OpenGL rendering for sokoban ;
-
-: draw-block ( block -- )
- { 1 1 } gl-fill-rect ;
-
-: draw-sprite ( block path -- )
- load-image swap <texture> { 1 1 } swap draw-scaled-texture ;
-
-:: draw-piece-blocks ( piece -- )
- piece piece-blocks [ piece path>> draw-sprite ] each ;
-
-: draw-piece ( piece -- )
- dup layout>> color>> gl-color draw-piece-blocks ;
-
-: draw-goal ( block -- )
- { 0.38 0.38 } v+ { 0.24 0.24 } gl-fill-rect ;
-
-: draw-goal-blocks ( piece -- )
- ! implement goals the same way we do as walls
- wall-blocks [ draw-goal ] each ;
-
-: draw-goal-piece ( piece -- )
- dup layout>> color>> gl-color draw-goal-blocks ;
-
-! TODO: move implementation specific stuff into sokoban-board
-: (draw-row) ( x y row -- )
- overd nth [ gl-color 2array draw-block ] [ 2drop ] if* ;
-
-: draw-row ( y row -- )
- [ length <iota> swap ] keep [ (draw-row) ] 2curry each ;
-
-: draw-board ( board -- )
- rows>> [ swap draw-row ] each-index ;
-
-: scale-board ( width height board -- )
- [ width>> ] [ height>> ] bi swapd [ / ] dup 2bi* 1 glScalef ;
-
-: set-background-color ( sokoban -- )
- dup running?>> [
- paused?>> COLOR: light-gray COLOR: white ?
- ] [ drop COLOR: black ] if gl-color ;
-
-: draw-background ( board -- )
- [ 0 0 ] dip [ width>> ] [ height>> ] bi glRectf ;
-
-: draw-sokoban ( width height sokoban -- )
- ! width and height are in pixels
- [
- {
- [ board>> scale-board ]
- [ set-background-color ]
- [ board>> draw-background ]
- [ board>> draw-board ]
- [ player>> draw-piece ]
- [ goals>> draw-goal-piece ]
- [ boxes>> [ draw-piece ] each ]
- } cleave
- ] do-matrix ;
+++ /dev/null
-! Copyright (C) 2006, 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays namespaces sequences math math.order
-math.vectors colors random ;
-IN: sokoban.layout
-
-TUPLE: layout states color ;
-
-C: <layout> layout
-
-SYMBOL: component
-
-{
- [ ! walls on each level
- {
- {
- { 2 0 } { 3 0 } { 4 0 } { 5 0 } { 6 0 }
- { 0 1 } { 1 1 } { 2 1 } { 6 1 }
- { 0 2 } { 6 2 }
- { 0 3 } { 1 3 } { 2 3 } { 6 3 }
- { 0 4 } { 2 4 } { 3 4 } { 6 4 }
- { 0 5 } { 2 5 } { 6 5 } { 7 5 }
- { 0 6 } { 7 6 }
- { 0 7 } { 7 7 }
- { 0 8 } { 1 8 } { 2 8 } { 3 8 } { 4 8 } { 5 8 } { 6 8 } { 7 8 }
- }
- { ! new level (access it by rotating the level piece)
- { 4 0 } { 5 0 } { 6 0 } { 7 0 } { 8 0 }
- { 4 1 } { 8 1 }
- { 4 2 } { 8 2 }
- { 2 3 } { 3 3 } { 4 3 } { 8 3 } { 9 3 } { 10 3 }
- { 2 4 } { 10 4 }
- { 0 5 } { 1 5 } { 2 5 } { 4 5 } { 6 5 } { 7 5 } { 8 5 } { 10 5 } { 16 5 } { 17 5 } { 18 5 } { 19 5 } { 20 5 } { 21 5 }
- { 0 6 } { 4 6 } { 6 6 } { 7 6 } { 8 6 } { 10 6 } { 11 6 } { 12 6 } { 13 6 } { 14 6 } { 15 6 } { 16 6 } { 21 6 }
- { 0 7 } { 21 7 }
- { 0 8 } { 1 8 } { 2 8 } { 3 8 } { 4 8 } { 6 8 } { 7 8 } { 8 8 } { 10 8 } { 12 8 } { 13 8 } { 14 8 } { 15 8 } { 16 8 } { 21 8 }
- { 4 9 } { 10 9 } { 11 9 } { 12 9 } { 16 9 } { 17 9 } { 18 9 } { 19 9 } { 20 9 } { 21 9 }
- { 4 10 } { 5 10 } { 6 10 } { 7 10 } { 8 10 } { 9 10 } { 10 10 }
-
- }
- } COLOR: gray
- ]
- [ ! player position on each level
- {
- {
- { 2 2 }
- }
- {
- { 11 8 }
- }
- } COLOR: green
- ]
- [
- {
- {
- { 1 2 } { 5 3 } { 1 4 } { 4 5 } { 3 6 } { 6 6 } { 4 7 }
- }
- {
- { 19 6 } { 20 6 }
- { 19 7 } { 20 7 }
- { 19 8 } { 20 8 }
- }
- } COLOR: pink
- ]
-} [ first2 <layout> ] map component set-global
-
-SYMBOL: boxes
-{
- { ! first box on each level
- {
- { ! level 0
- { 3 2 }
- }
-
- { ! level 1
- { 5 2 }
- }
- } COLOR: orange
- }
-
- { ! second box on each level
- {
- { ! level 0
- { 4 3 }
- }
-
- { ! level 1
- { 7 3 }
- }
- } COLOR: orange
- }
-
- { ! third box on each level
- {
- { ! level 0
- { 4 4 }
- }
- { ! level 1
- { 5 4 }
- }
- } COLOR: orange
- }
-
- { ! fourth box on each level
- {
- { ! level 0
- { 4 6 }
- }
- { ! level 1
- { 8 4 }
- }
- } COLOR: orange
- }
-
- { ! fifth box on each level
- {
- { ! level 0
- { 3 6 }
- }
- { ! level 1
- { 5 7 }
- }
- } COLOR: orange
- }
-
- { ! sixth box on each level
- {
- { ! level 0
- { 5 6 }
- }
- { ! level 1
- { 2 7 }
- }
- } COLOR: orange
- }
-
- { ! seventh box on each level
- {
- { ! level 0
- { 1 6 }
- }
- } COLOR: orange
- }
-
- ! etc
-} [ first2 <layout> ] map boxes set-global
-
-
-SYMBOL: num-boxes
-{
- ! number of boxes -1 of each level
- 6
- 5
-} num-boxes set-global
-
-: get-board ( -- layout )
- component get first ;
-
-: get-player ( -- layout )
- component get second ;
-
-: get-box ( n -- layout )
- boxes get nth ;
- ! TODO add an n argument and get (n + 1)th
-
-: get-goal ( -- layout )
- component get third ;
-
-: get-num-boxes ( n -- m )
- ! outputs how many boxes are on each level, allows for different numbers of boxes per level
- num-boxes get nth ;
+++ /dev/null
-! Copyright (C) 2006, 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel math math.vectors sequences
-sokoban.layout lists.lazy namespaces colors
-ranges random ;
-IN: sokoban.piece
-
-! The level_num is an index into the layout's states array,
-! and the position is added to the layout's blocks to give
-! them their location on the sokoban board. If the location is f
-! then the piece is not yet on the board.
-
-TUPLE: piece
- { layout layout }
- { level_num integer initial: 0 }
- { location array initial: { 0 0 } }
- { path } ;
-
-: <piece> ( layout -- piece )
- piece new swap >>layout ;
-
-: (piece-blocks) ( piece -- blocks )
- ! rotates the piece
- [ level_num>> ] [ layout>> states>> ] bi nth ;
-
-: wall-blocks ( piece -- blocks )
- [ (piece-blocks) ] [ location>> ] bi [ v+ ] curry map ;
-
-: piece-blocks ( piece -- blocks )
- location>> { } 1sequence ; ! literally just returns the location in a sequence
-
-: set-location ( piece level -- piece )
- ! sets the location of piece to where they are defined in layout
- over layout>> states>> nth first >>location ;
-
-: is-goal? ( goal-piece location move -- ? )
- ! check if next move is a goal or not
- v+ swap [ level_num>> ] [ layout>> ] bi states>> nth member? ;
-
-: <board-piece> ( -- piece )
- get-board <piece> ;
-
-: <player-piece> ( level -- piece )
- get-player <piece> swap set-location "vocab:sokoban/resources/CharR.png" >>path ;
-
-
-:: <box-piece> ( box-number goal-piece level -- piece )
- box-number get-box <piece> level set-location "vocab:sokoban/resources/Crate_Yellow.png" >>path dup [ layout>> ] [ location>> ] bi
- goal-piece swap { 0 0 } is-goal?
- [
- COLOR: blue
- ]
- [
- COLOR: orange
- ] if
- >>color drop ;
-
-:: <box-seq> ( goal-piece level -- seq )
- ! get list of boxes on corresponding level
- level get-num-boxes [0..b] [ goal-piece level <box-piece> ] map ;
-
-: (rotate-piece) ( level_num inc n-states -- level_num' )
- [ + ] dip rem ;
-
-: rotate-piece ( piece inc -- piece )
- over layout>> states>> length
- [ (rotate-piece) ] 2curry change-level_num ;
-
-: <goal-piece> ( level -- piece )
- ! rotate goal according to level
- get-goal <piece> swap rotate-piece ;
-
-
-: move-piece ( piece move -- piece )
- [ v+ ] curry change-location ;
+++ /dev/null
-! Copyright (C) 2006, 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors timers arrays calendar destructors kernel make math math.rectangles
-math.parser namespaces sequences system sokoban.game sokoban.layout sokoban.gl sokoban.sound ui.gadgets
-ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures
-ui.render ui ;
-IN: sokoban
-
-TUPLE: sokoban-gadget < gadget { sokoban sokoban } { timer } { window-dims array initial: { 700 800 } } ;
-
-: <sokoban-gadget> ( sokoban -- gadget )
- create-engine >>engine
- sokoban-gadget new swap >>sokoban ;
-
-:: get-dim ( sokoban level -- level w h )
- ! Look for maximum height and width of wall layout to determine size of board
- level component get first states>> nth :> new_board
- level
- new_board [ first ] map supremum 1 +
- new_board [ second ] map supremum 1 + ;
-
-: new-sokoban ( gadget -- gadget )
- ! Restarts sokoban without changing levels
- dup sokoban>> engine>> swap
- [ dup level>> get-dim <sokoban> ] change-sokoban
- swap over sokoban>> swap >>engine >>sokoban ;
-
-:: window-size ( sokoban -- window-size )
- sokoban level>> :> level
- sokoban level get-dim :> ( lev w h )
- 100 w * :> xpix
- 100 h * :> ypix
- { xpix ypix } ;
-
-
-: update-sokoban ( gadget -- gadget )
- ! Changes to the next level of sokoban
- dup sokoban>> engine>> swap
- [ dup level>> 1 + get-dim <sokoban> ] change-sokoban
- dup sokoban>> window-size >>window-dims
- swap over sokoban>> swap >>engine >>sokoban ;
-
-M: sokoban-gadget pref-dim* ( gadget -- dim )
- sokoban>> window-size ;
- ! drop { 700 800 } ; ! needs to be changed as well
-
-: update-status ( gadget -- )
- dup sokoban>> [
- [ "Level: " % level>> # ]
- [ paused?>> [ " (Paused)" % ] when ] bi
- ] "" make swap show-status ;
-
-M: sokoban-gadget draw-gadget* ( gadget -- )
- [
- [ dim>> first2 ] [ sokoban>> ] bi draw-sokoban
- ] keep update-status ;
-
-: unless-paused ( sokoban quot -- )
- over sokoban>> paused?>> [
- 2drop
- ] [
- call
- ] if ; inline
-
-sokoban-gadget H{
- { T{ button-down f f 1 } [ request-focus ] }
- { T{ key-down f f "UP" } [ [ sokoban>> move-up ] unless-paused ] }
- { T{ key-down f f "LEFT" } [ [ sokoban>> move-left ] unless-paused ] }
- { T{ key-down f f "RIGHT" } [ [ sokoban>> move-right ] unless-paused ] }
- { T{ key-down f f "DOWN" } [ [ sokoban>> move-down ] unless-paused ] }
- { T{ key-down f f "p" } [ sokoban>> toggle-pause ] }
- { T{ key-down f f "n" } [ new-sokoban drop ] }
-} set-gestures
-
-: tick ( gadget -- )
- dup sokoban>> update-level? [
- update-sokoban
- relayout-window
- ] [
- relayout-1
- ] if
- ;
-
-M: sokoban-gadget graft* ( gadget -- )
- [ [ tick ] curry 100 milliseconds every ] keep timer<< ;
-
-M: sokoban-gadget ungraft* ( gadget -- )
- dup sokoban>> engine>> dispose
- [ stop-timer f ] change-timer drop ;
-
-: sokoban-window ( -- )
- [
- <default-sokoban> <sokoban-gadget>
- "sokoban" open-status-window
- ] with-ui ;
-
-MAIN: sokoban-window
+++ /dev/null
-! Copyright (C) 2009 Joe Groff.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors timers audio audio.engine audio.loader calendar
-destructors io kernel locals math math.functions ranges specialized-arrays
-sequences random math.vectors literals ;
-
-
-IN: sokoban.sound
-
-: create-engine ( -- engine )
- f 10 <audio-engine> ;
-
-:: play-beep ( engine -- )
- $[ "vocab:sokoban/resources/once.wav" read-audio ] :> once-sound
- engine start-audio*
-
- engine T{ audio-source f { 0.0 0.0 0.0 } 1.0 { 0.0 0.0 0.0 } f } once-sound f
- play-static-audio-clip drop ;
+++ /dev/null
-Graphical sokoban game
+++ /dev/null
-demos
-applications
-games
projects / factor.git / commitdiff
