Paste: the tetris game

! Copyright (C) 2006, 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators kernel lists math math.functions sequences system tetris.board tetris.piece tetris.tetromino ;
IN: tetris.game

TUPLE: tetris
    { board board }
    { pieces }
    { last-update integer initial: 0 }
    { rows integer initial: 0 }
    { score integer initial: 0 }
    { paused? initial: f }
    { running? initial: t } ;

CONSTANT: default-width 10
CONSTANT: default-height 20

: <tetris> ( width height -- tetris )
    dupd <board> swap <piece-llist>
    tetris new swap >>pieces swap >>board ;
        
: <default-tetris> ( -- tetris ) default-width default-height <tetris> ;

: <new-tetris> ( old -- new )
    board>> [ width>> ] [ height>> ] bi <tetris> ;

: current-piece ( tetris -- piece ) pieces>> car ;

: next-piece ( tetris -- piece ) pieces>> cdr car ;

: toggle-pause ( tetris -- )
    [ not ] change-paused? drop ;

: level>> ( tetris -- level )
    rows>> 1+ 10 / ceiling ;

: update-interval ( tetris -- interval )
    level>> 1- 60 * 1000 swap - ;

: add-block ( tetris block -- )
    over board>> spin current-piece tetromino>> colour>> set-block ;

: game-over? ( tetris -- ? )
    [ board>> ] [ next-piece ] bi piece-valid? not ;

: new-current-piece ( tetris -- tetris )
    dup game-over? [
        f >>running?
    ] [
        [ cdr ] change-pieces
    ] if ;

: rows-score ( level n -- score )
    {
        { 0 [ 0 ] }
        { 1 [ 40 ] }
        { 2 [ 100 ] }
        { 3 [ 300 ] }
        { 4 [ 1200 ] }
    } case swap 1+ * ;

: add-score ( tetris n-rows -- tetris )
    over level>> swap rows-score swap [ + ] change-score ;

: add-rows ( tetris rows -- tetris )
    swap [ + ] change-rows ;

: score-rows ( tetris n -- )
    [ add-score ] keep add-rows drop ;

: lock-piece ( tetris -- )
    [ dup current-piece piece-blocks [ add-block ] with each ] keep
    new-current-piece dup board>> check-rows score-rows ;

: can-rotate? ( tetris -- ? )
    [ board>> ] [ current-piece clone 1 rotate-piece ] bi piece-valid? ;

: (rotate) ( inc tetris -- )
    dup can-rotate? [ current-piece swap rotate-piece drop ] [ 2drop ] if ;

: rotate-left ( tetris -- ) -1 swap (rotate) ;

: rotate-right ( tetris -- ) 1 swap (rotate) ;

: can-move? ( tetris move -- ? )
    [ drop board>> ] [ [ current-piece clone ] dip move-piece ] 2bi piece-valid? ;

: tetris-move ( tetris move -- ? )
    #! moves the piece if possible, returns whether the piece was moved
    2dup can-move? [
        [ current-piece ] dip move-piece drop t
    ] [
        2drop f
    ] if ;

: move-left ( tetris -- ) { -1 0 } tetris-move drop ;

: move-right ( tetris -- ) { 1 0 } tetris-move drop ;

: move-down ( tetris -- )
    dup { 0 1 } tetris-move [ drop ] [ lock-piece ] if ;

: move-drop ( tetris -- )
    dup { 0 1 } tetris-move [ move-drop ] [ lock-piece ] if ;

: update ( tetris -- )
    millis over last-update>> -
    over update-interval > [
        dup move-down
        millis >>last-update
    ] when drop ;

: ?update ( tetris -- )
    dup [ paused?>> ] [ running?>> not ] bi or [ drop ] [ update ] if ;

Annotation: the board

! Copyright (C) 2006, 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math sequences tetris.piece ;
IN: tetris.board

TUPLE: board { width integer } { height integer } rows ;

: make-rows ( width height -- rows )
    [ drop f <array> ] with map ;

: <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 tetris 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 colour -- ) -rot board@block set-nth ;
  
: block ( board block -- colour ) board@block nth ;

: block-free? ( board block -- ? ) block not ;

: block-in-bounds? ( board block -- ? )
    [ first swap width>> bounds-check? ] 2keep
    second swap height>> bounds-check? and ;

: location-valid? ( board block -- ? )
    2dup block-in-bounds? [ block-free? ] [ 2drop f ] if ;

: piece-valid? ( board piece -- ? )
    piece-blocks [ location-valid? ] with all? ;

: row-not-full? ( row -- ? ) f swap member? ;

: add-row ( board -- board )
    dup rows>> over width>> f <array> prefix >>rows ;

: top-up-rows ( board -- )
    dup height>> over rows>> length = [
        drop
    ] [
        add-row top-up-rows
    ] if ;

: remove-full-rows ( board -- board )
    [ [ row-not-full? ] filter ] change-rows ;

: check-rows ( board -- n )
    #! remove full rows, then add blank ones at the top, returning the number
    #! of rows removed (and added)
    remove-full-rows dup height>> over rows>> length - swap top-up-rows ;

Annotation: gl

! Copyright (C) 2006, 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators kernel math math.vectors
namespaces opengl opengl.gl sequences tetris.board tetris.game
tetris.piece ui.render tetris.tetromino ui.gadgets colors ;
IN: tetris.gl

#! OpenGL rendering for tetris

: draw-block ( block -- )
    { 1 1 } gl-fill-rect ;

: draw-piece-blocks ( piece -- )
    piece-blocks [ draw-block ] each ;

: draw-piece ( piece -- )
    dup tetromino>> colour>> gl-color draw-piece-blocks ;

: draw-next-piece ( piece -- )
    dup tetromino>> colour>>
    >rgba-components drop 0.2 <rgba> gl-color draw-piece-blocks ;

! TODO: move implementation specific stuff into tetris-board
: (draw-row) ( x y row -- )
    [ over ] dip nth dup
    [ gl-color 2array draw-block ] [ 3drop ] if ;

: draw-row ( y row -- )
    dup length -rot [ (draw-row) ] 2curry each ;

: draw-board ( board -- )
    rows>> dup length swap
    [ dupd nth draw-row ] curry each ;

: scale-board ( width height board -- )
    [ width>> ] [ height>> ] bi swapd [ / ] dup 2bi* 1 glScalef ;

: draw-tetris ( width height tetris -- )
    #! width and height are in pixels
    [
        {
            [ board>> scale-board ]
            [ board>> draw-board ]
            [ next-piece draw-next-piece ]
            [ current-piece draw-piece ]
        } cleave
    ] do-matrix ;

Annotation: piece

! Copyright (C) 2006, 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math math.vectors sequences tetris.tetromino lists.lazy ;
IN: tetris.piece

#! The rotation is an index into the tetromino's states array, and the
#! position is added to the tetromino's blocks to give them their location on the
#! tetris board. If the location is f then the piece is not yet on the board.

TUPLE: piece
    { tetromino tetromino }
    { rotation integer initial: 0 }
    { location array initial: { 0 0 } } ;

: <piece> ( tetromino -- piece )
    piece new swap >>tetromino ;

: (piece-blocks) ( piece -- blocks )
    #! rotates the piece
    [ rotation>> ] [ tetromino>> states>> ] bi nth ;

: piece-blocks ( piece -- blocks )
    #! rotates and positions the piece
    [ (piece-blocks) ] [ location>> ] bi [ v+ ] curry map ;

: piece-width ( piece -- width )
    piece-blocks blocks-width ;

: set-start-location ( piece board-width -- piece )
    over piece-width [ 2 /i ] bi@ - 0 2array >>location ;

: <random-piece> ( board-width -- piece )
    random-tetromino <piece> swap set-start-location ;

: <piece-llist> ( board-width -- llist )
    [ [ <random-piece> ] curry ] keep [ <piece-llist> ] curry lazy-cons ;

: modulo ( n m -- n )
  #! -2 7 mod => -2, -2 7 modulo =>  5
  tuck mod over + swap mod ;

: (rotate-piece) ( rotation inc n-states -- rotation' )
    [ + ] dip modulo ;

: rotate-piece ( piece inc -- piece )
    over tetromino>> states>> length
    [ (rotate-piece) ] 2curry change-rotation ;

: move-piece ( piece move -- piece )
    [ v+ ] curry change-location ;

Annotation: main module

! Copyright (C) 2006, 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alarms arrays calendar kernel make math math.rectangles math.parser namespaces sequences system tetris.game tetris.gl ui.gadgets ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui ;
IN: tetris

TUPLE: tetris-gadget < gadget { tetris tetris } { alarm } ;

: <tetris-gadget> ( tetris -- gadget )
    tetris-gadget new swap >>tetris ;

M: tetris-gadget pref-dim* drop { 200 400 } ;

: update-status ( gadget -- )
    dup tetris>> [
        "Level: " % dup level>> #
        " Score: " % score>> #
    ] "" make swap show-status ;

M: tetris-gadget draw-gadget* ( gadget -- )
    [
        [ dim>> first2 ] [ tetris>> ] bi draw-tetris
    ] keep update-status ;

: new-tetris ( gadget -- gadget )
    [ <new-tetris> ] change-tetris ;

tetris-gadget H{
    { T{ button-down f f 1 }     [ request-focus ] }
    { T{ key-down f f "UP" }     [ tetris>> rotate-right ] }
    { T{ key-down f f "d" }      [ tetris>> rotate-left ] }
    { T{ key-down f f "f" }      [ tetris>> rotate-right ] }
    { T{ key-down f f "e" }      [ tetris>> rotate-left ] } ! dvorak d
    { T{ key-down f f "u" }      [ tetris>> rotate-right ] } ! dvorak f
    { T{ key-down f f "LEFT" }   [ tetris>> move-left ] }
    { T{ key-down f f "RIGHT" }  [ tetris>> move-right ] }
    { T{ key-down f f "DOWN" }   [ tetris>> move-down ] }
    { T{ key-down f f " " }      [ tetris>> move-drop ] }
    { T{ key-down f f "p" }      [ tetris>> toggle-pause ] }
    { T{ key-down f f "n" }      [ new-tetris drop ] }
} set-gestures

: tick ( gadget -- )
    [ tetris>> ?update ] [ relayout-1 ] bi ;

M: tetris-gadget graft* ( gadget -- )
    [ [ tick ] curry 100 milliseconds every ] keep (>>alarm) ;

M: tetris-gadget ungraft* ( gadget -- )
    [ cancel-alarm f ] change-alarm drop ;

: tetris-window ( -- ) 
    [
        <default-tetris> <tetris-gadget>
        "Tetris" open-status-window
    ] with-ui ;

MAIN: tetris-window

Annotation: tetronimo

! 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 colors.constants random ;
IN: tetris.tetromino

TUPLE: tetromino states colour ;

C: <tetromino> tetromino

SYMBOL: tetrominoes

{
  [
    { {
        { 0 0 } { 1 0 } { 2 0 } { 3 0 }
      } 
      { { 0 0 }
        { 0 1 }
        { 0 2 }
        { 0 3 }
      }
    } COLOR: cyan
  ] [
    {
      {         { 1 0 }
        { 0 1 } { 1 1 } { 2 1 }
      } {
        { 0 0 }
        { 0 1 } { 1 1 }
        { 0 2 }
      } {
        { 0 0 } { 1 0 } { 2 0 }
                { 1 1 }
      } {
                { 1 0 }
        { 0 1 } { 1 1 }
                { 1 2 }
      }
    } COLOR: purple
  ] [
    { { { 0 0 } { 1 0 }
        { 0 1 } { 1 1 } }
    } COLOR: yellow
  ] [
    {
      { { 0 0 } { 1 0 } { 2 0 }
        { 0 1 }
      } {
        { 0 0 } { 1 0 }
                { 1 1 }
                { 1 2 }
      } {
                        { 2 0 }
        { 0 1 } { 1 1 } { 2 1 }
      } {
        { 0 0 }
        { 0 1 }
        { 0 2 } { 1 2 }
      }
    } COLOR: orange
  ] [
    { 
      { { 0 0 } { 1 0 } { 2 0 }
                        { 2 1 }
      } {
                { 1 0 }
                { 1 1 }
        { 0 2 } { 1 2 }
      } {
        { 0 0 }
        { 0 1 } { 1 1 } { 2 1 }
      } {
        { 0 0 } { 1 0 }
        { 0 1 }
        { 0 2 }
      }
    } COLOR: blue
  ] [
    {
      {          { 1 0 } { 2 0 }
        { 0 1 } { 1 1 }
      } {
        { 0 0 }
        { 0 1 } { 1 1 }
                { 1 2 }
      }
    } COLOR: green
  ] [
    {
      {
        { 0 0 } { 1 0 }
                { 1 1 } { 2 1 }
      } {
                { 1 0 }
        { 0 1 } { 1 1 }
        { 0 2 }
      }
    } COLOR: red
  ]
} [ first2 <tetromino> ] map tetrominoes set-global

: random-tetromino ( -- tetromino )
    tetrominoes get random ;

: blocks-max ( blocks quot -- max )
    map [ 1+ ] [ max ] map-reduce ; inline

: blocks-width ( blocks -- width )
    [ first ] blocks-max ;

: blocks-height ( blocks -- height )
    [ second ] blocks-max ;

New Annotation