Skip to content
This repository
branch: master
Martin Berends October 03, 2011
file 165 lines (151 sloc) 5.876 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164
# gtk-tetris.pl for Niecza Perl 6
# Docs: http://en.wikipedia.org/wiki/Tetris

constant $GTK = "gtk-sharp, Version=2.12.0.0, Culture=neutral, PublicKeyToken=35e10195dab3c99f";
constant $GDK = "gdk-sharp, Version=2.12.0.0, Culture=neutral, PublicKeyToken=35e10195dab3c99f";
constant $GLIB = "glib-sharp, Version=2.12.0.0, Culture=neutral, PublicKeyToken=35e10195dab3c99f";

# Class names that occur more than once. Classes used only once appear inline.
constant Application = CLR::("Gtk.Application,$GTK");
constant GLibTimeout = CLR::("GLib.Timeout,$GLIB");

# Application data
constant matrixRows = 20; constant matrixColumns = 10;
my @tetrominoes = # cell coordinates relative to the "middle" cell
    [ -1, 0, 0, 0, 1, 0, 2, 0 ], # I
    [ -1, 0, 0, 0, 1, 0, 1, 1 ], # J
    [ -1, 1, -1, 0, 0, 0, 1, 0 ], # L
    [ -1, 1, -1, 0, 0, 0, 0, 1 ], # O
    [ -1, 1, 0, 1, 0, 0, 1, 0 ], # S
    [ -1, 0, 0, 0, 0, 1, 1, 0 ], # T
    [ -1, 0, 0, 0, 0, 1, 1, 1 ]; # Z
my @colors = # Copied approximately from the PC version
    [0, 0, 0 ], # 0: black background
    [0.5.Num, 0, 0 ], # 1: I maroon
    [1, 1, 1 ], # 2: J white
    [0.9.Num, 0, 0.9.Num], # 3: L dark magenta
    [0, 0, 0.6.Num], # 4: O dark blue
    [0, 0.8.Num, 0 ], # 5: S green
    [0.7.Num, 0.7.Num, 0 ], # 6: T brown
    [0, 0.8.Num, 0.8.Num]; # 7: Z dark cyan
my @matrix;
for ^matrixRows -> $i { for ^matrixColumns -> $j { @matrix[$i][$j] = 0; } }
my $pieceX; my $pieceY; my $colorindex; my @piece; CreatePiece();
my $oldInterval = 300;
my $newInterval = 300;
my $scale; my $offsetX; my $offsetY;

# ---------------------------- Main program ----------------------------
Application.Init;
my $window = CLR::("Gtk.Window,$GTK").new("tetris");
$window.SetDefaultSize(300, 500);
my $drawingarea = CLR::("Gtk.DrawingArea,$GTK").new;
$window.Add($drawingarea);
$window.add_DeleteEvent(sub ($obj,$args){$obj;$args;Application.Quit;});
$drawingarea.CanFocus = True; # let arrow keys create KeyPressEvents
$drawingarea.add_ExposeEvent(&ExposeEvent);
$drawingarea.add_KeyPressEvent(&KeyPressEvent);
$window.ShowAll;
GLibTimeout.Add($newInterval, &TimeoutEvent);
Application.Run;

# --------------------------- Event handlers ---------------------------
sub TimeoutEvent()
{
    $drawingarea.QueueDraw;
    my $intervalSame = ($newInterval == $oldInterval);
    unless $intervalSame { GLibTimeout.Add($newInterval, &TimeoutEvent); }
    return $intervalSame; # True means continue calling this timeout handler
}

sub KeyPressEvent($sender, $eventargs) #OK not used
{
    given $eventargs.Event.Key {
        when 'Up' { if $colorindex != 4 { TryRotatePiece() } }
        when 'Down' { while CanMovePiece(0,1) {++$pieceY;} }
        when 'Left' { if CanMovePiece(-1,0) {--$pieceX;} }
        when 'Right' { if CanMovePiece( 1,0) {++$pieceX;} }
    }
    return True; # means this keypress is now handled
}

sub ExposeEvent($sender, $eventargs) #OK not used
{
    my $cc = CLR::("Gdk.CairoHelper,$GDK").Create($sender.GdkWindow); # Cairo Context
    my $windowX=0; my $windowY=0; my $windowWidth=0; my $windowHeight=0; my $windowDepth=0;
    $sender.GdkWindow.GetGeometry($windowX, $windowY, $windowWidth, $windowHeight, $windowDepth);
    $scale = ((($windowWidth / matrixColumns) min ($windowHeight / matrixRows)) * 0.95).Int;
    $offsetX = (($windowWidth - ($scale * matrixColumns))/2).Int;
    $offsetY = (($windowHeight - ($scale * matrixRows ))/2).Int;
    $cc.SetSourceRGB(0, 0, 0.4.Num); $cc.Paint; # Dark blue background
    TryMovePieceDown(); # also clears full rows and makes new pieces
    DrawMatrix($cc);
    DrawPiece($cc);
    $cc.dispose-hack; # Should be $cc.IDisposable.Dispose but currently
    # CLR interop cannot call explicitly defined interface methods.
    # Tracked as https://github.com/sorear/niecza/issues/56
}

# ------------------------- Helper subroutines -------------------------
sub CreatePiece()
{
    my $piece = (rand * 7).Int % 7; # TODO: ^7.pick;
    $colorindex = $piece + 1;
    @piece = @( @tetrominoes[$piece] );
    $pieceX = 4;
    $pieceY = 0;
}

sub CanMovePiece($deltaX, $deltaY)
{
    my $canMove = True;
    # Would any cell of the piece go below the bottom of the well,
    # or overlap existing cells lying there?
    for @piece -> $x, $y {
        if $x+$pieceX+$deltaX < 0 || $x+$pieceX+$deltaX >= matrixColumns ||
           $y+$pieceY+$deltaY < 0 || $y+$pieceY+$deltaY >= matrixRows ||
           @matrix[$y+$pieceY+$deltaY][$x+$pieceX+$deltaX] != 0
        {
            $canMove = False;
        }
    }
    $canMove;
}

sub TryMovePieceDown()
{
    if CanMovePiece(0, 1) {
        ++$pieceY;
    }
    else { # Copy this piece into the matrix and start with a new piece
        for @piece -> $x, $y {
            @matrix[$y+$pieceY][$x+$pieceX] = $colorindex;
        }
        # Look for full rows and remove them. TODO: keep score.
        @matrix = grep { !all(@$_) }, @matrix;
        unshift @matrix, [ 0 xx matrixColumns ] while @matrix < matrixRows;
        CreatePiece();
    }
}

sub TryRotatePiece()
{
    my @p = @piece;
    @piece .= map({ $^b, -$^a });
    if ! CanMovePiece(0, 0) {
        @piece = @p;
    }
}

sub DrawMatrix($cc)
{
    my $x=0; my $y=0;
    for ^matrixRows -> $row {
        for ^matrixColumns -> $column {
            $cc.SetSourceRGB(|@colors[@matrix[$row][$column]]);
            $cc.Rectangle($x+$offsetX,$y+$offsetY,$scale,$scale);
            $cc.Fill;
            $x += $scale;
        }
        $x = 0;
        $y += $scale;
    }
    $cc.Stroke;
}

sub DrawPiece($cc)
{
    $cc.SetSourceRGB(|@colors[$colorindex]);
    for @piece -> $x, $y {
        $cc.Rectangle(($pieceX+$x)*$scale+$offsetX,($pieceY+$y)*$scale+$offsetY,$scale,$scale);
        $cc.Fill;
    }
    $cc.Stroke;
}
Something went wrong with that request. Please try again.