extra/sokoban/sokoban.factor

   1 ! Copyright (C) 2006, 2007, 2008 Alex Chapman
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors timers arrays calendar destructors kernel make math math.rectangles
   4 math.parser namespaces sequences system sokoban.game sokoban.layout sokoban.gl sokoban.sound ui.gadgets
   5 ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures
   6 ui.render ui ;
   7 IN: sokoban
   8
   9 TUPLE: sokoban-gadget < gadget { sokoban sokoban } { timer } { window-dims array initial: { 700 800 } } ;
  10
  11 : <sokoban-gadget> ( sokoban -- gadget )
  12     create-engine >>engine
  13     sokoban-gadget new swap >>sokoban ;
  14
  15 :: get-dim ( sokoban level -- level w h )
  16     ! Look for maximum height and width of wall layout to determine size of board
  17     level component get first states>> nth :> new_board
  18     level
  19     new_board [ first ] map supremum 1 +
  20     new_board [ second ] map supremum 1 + ;
  21
  22 : new-sokoban ( gadget -- gadget )
  23     ! Restarts sokoban without changing levels
  24     dup sokoban>> engine>> swap
  25     [ dup level>> get-dim <sokoban> ] change-sokoban
  26     swap over sokoban>> swap >>engine >>sokoban ;
  27
  28 :: window-size ( sokoban -- window-size )
  29     sokoban level>> :> level
  30     sokoban level get-dim :> ( lev w h )
  31     100 w * :> xpix
  32     100 h * :> ypix
  33     { xpix ypix } ;
  34
  35
  36 : update-sokoban ( gadget -- gadget )
  37     ! Changes to the next level of sokoban
  38     dup sokoban>> engine>> swap
  39     [ dup level>> 1 + get-dim <sokoban> ] change-sokoban
  40     dup sokoban>> window-size >>window-dims
  41     swap over sokoban>> swap >>engine >>sokoban ;
  42
  43 M: sokoban-gadget pref-dim* ( gadget -- dim )
  44     sokoban>> window-size ;
  45     ! drop { 700 800 } ; ! needs to be changed as well
  46
  47 : update-status ( gadget -- )
  48     dup sokoban>> [
  49         [ "Level: " % level>> # ]
  50         [ paused?>> [ " (Paused)" % ] when ] bi
  51     ] "" make swap show-status ;
  52
  53 M: sokoban-gadget draw-gadget* ( gadget -- )
  54     [
  55         [ dim>> first2 ] [ sokoban>> ] bi draw-sokoban
  56     ] keep update-status ;
  57
  58 : unless-paused ( sokoban quot -- )
  59     over sokoban>> paused?>> [
  60         2drop
  61     ] [
  62         call
  63     ] if ; inline
  64
  65 sokoban-gadget H{
  66     { T{ button-down f f 1 }     [ request-focus ] }
  67     { T{ key-down f f "UP" }     [ [ sokoban>> move-up ] unless-paused ] }
  68     { T{ key-down f f "LEFT" }   [ [ sokoban>> move-left ] unless-paused ] }
  69     { T{ key-down f f "RIGHT" }  [ [ sokoban>> move-right ] unless-paused ] }
  70     { T{ key-down f f "DOWN" }   [ [ sokoban>> move-down ] unless-paused ] }
  71     { T{ key-down f f "p" }      [ sokoban>> toggle-pause ] }
  72     { T{ key-down f f "n" }      [ new-sokoban drop ] }
  73 } set-gestures
  74
  75 : tick ( gadget -- )
  76     dup sokoban>> update-level? [
  77         update-sokoban
  78         relayout-window
  79     ] [
  80         relayout-1
  81     ] if
  82      ;
  83
  84 M: sokoban-gadget graft* ( gadget -- )
  85     [ [ tick ] curry 100 milliseconds every ] keep timer<< ;
  86
  87 M: sokoban-gadget ungraft* ( gadget -- )
  88     dup sokoban>> engine>> dispose
  89     [ stop-timer f ] change-timer drop ;
  90
  91 : sokoban-window ( -- )
  92     [
  93         <default-sokoban> <sokoban-gadget>
  94         "sokoban" open-status-window
  95     ] with-ui ;
  96
  97 MAIN: sokoban-window