apps/tetris/tetris.factor

   1 ! Copyright (C) 2006 Alex Chapman
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel generic sequences math tetris-board tetris-piece tetromino errors lazy-lists ;
   4 IN: tetris
   5
   6 TUPLE: tetris pieces last-update update-interval rows score game-state paused? running? ;
   7
   8 : default-width 10 ; inline
   9 : default-height 20 ; inline
  10
  11 C: tetris ( width height -- tetris )
  12     >r <board> r> [ set-delegate ] keep
  13     dup board-width <piece-llist> over set-tetris-pieces
  14     0 over set-tetris-last-update
  15     0 over set-tetris-rows
  16     0 over set-tetris-score
  17     f over set-tetris-paused?
  18     t over set-tetris-running? ;
  19
  20 : <default-tetris> ( -- tetris ) default-width default-height <tetris> ;
  21
  22 : <new-tetris> ( old -- new )
  23     [ board-width ] keep board-height <tetris> ;
  24
  25 : tetris-board ( tetris -- board ) delegate ;
  26
  27 : tetris-current-piece ( tetris -- piece ) tetris-pieces car ;
  28
  29 : tetris-next-piece ( tetris -- piece ) tetris-pieces cdr car ;
  30
  31 : toggle-pause ( tetris -- )
  32     dup tetris-paused? not swap set-tetris-paused? ;
  33
  34 : tetris-level ( tetris -- level )
  35     tetris-rows 1+ 10 / ceiling ;
  36
  37 : tetris-update-interval ( tetris -- interval )
  38     tetris-level 1- 60 * 1000 swap - ;
  39
  40 : add-block ( tetris block -- )
  41     over tetris-current-piece tetromino-colour board-set-block ;
  42
  43 : game-over? ( tetris -- ? )
  44     dup dup tetris-next-piece piece-valid? ;
  45
  46 : new-current-piece ( tetris -- )
  47     game-over? [
  48         dup tetris-pieces cdr swap set-tetris-pieces
  49     ] [
  50         f swap set-tetris-running?
  51     ] if ;
  52
  53 : rows-score ( level n -- score )
  54     {
  55         { [ dup 0 = ] [ drop 0 ]    }
  56         { [ dup 1 = ] [ drop 40 ]   }
  57         { [ dup 2 = ] [ drop 100 ]  }
  58         { [ dup 3 = ] [ drop 300 ]  }
  59         { [ dup 4 = ] [ drop 1200 ] }
  60         { [ t ] [ "how did you clear that many rows?" throw ] }
  61     } cond swap 1+ * ;
  62
  63 : add-score ( tetris score -- )
  64     over tetris-score + swap set-tetris-score ;
  65
  66 : score-rows ( tetris n -- )
  67     2dup >r dup tetris-level r> rows-score add-score
  68     over tetris-rows + swap set-tetris-rows ;
  69
  70 : lock-piece ( tetris -- )
  71     [ dup tetris-current-piece piece-blocks [ add-block ] each-with ] keep
  72     dup new-current-piece dup check-rows score-rows ;
  73
  74 : can-rotate? ( tetris -- ? )
  75     dup tetris-current-piece clone dup 1 rotate-piece piece-valid? ;
  76
  77 : (rotate) ( inc tetris -- )
  78     dup can-rotate? [ tetris-current-piece swap rotate-piece ] [ 2drop ] if ;
  79
  80 : rotate ( tetris -- ) 1 swap (rotate) ;
  81
  82 : can-move? ( tetris move -- ? )
  83     >r dup tetris-current-piece clone dup r> move-piece piece-valid? ;
  84
  85 : tetris-move ( tetris move -- ? )
  86     #! moves the piece if possible, returns whether the piece was moved
  87     2dup can-move? [
  88         >r tetris-current-piece r> move-piece t
  89     ] [
  90         2drop f
  91     ] if ;
  92
  93 : move-left ( tetris -- ) { -1 0 } tetris-move drop ;
  94
  95 : move-right ( tetris -- ) { 1 0 } tetris-move drop ;
  96
  97 : move-down ( tetris -- )
  98     dup { 0 1 } tetris-move [ drop ] [ lock-piece ] if ;
  99
 100 : move-drop ( tetris -- )
 101     dup { 0 1 } tetris-move [ move-drop ] [ lock-piece ] if ;
 102
 103 : can-move? ( tetris move -- ? )
 104     >r dup tetris-current-piece clone dup r> move-piece piece-valid? ;
 105
 106 : update ( tetris -- )
 107     millis over tetris-last-update -
 108     over tetris-update-interval > [
 109         dup move-down
 110         millis swap set-tetris-last-update
 111     ] [ drop ] if ;
 112
 113 : maybe-update ( tetris -- )
 114     dup tetris-paused? over tetris-running? not or [ drop ] [ update ] if ;