A Perl/Tk version of the 3-card trick

[qumsieh]

I was bored. So I quickly hacked together this implementation of the three-card trick (aka three-card monte). It kept me busy for a little while.

Enjoy.

#!perl

use strict;
use warnings;
use Tk;
use constant SIN => sin(3.14159265/18);
use constant COS => cos(3.14159265/18);

my $color = 'darkolivegreen';
my $score = 0;
my @delay = (30,
         20,
         15,
         10,
         5);

my $topText = "Keep your eye on the indicated box.\nPress Start to pla
+y.";
my $selFlag = 0;

my $mw = new MainWindow;
$mw->Label(-textvariable => \$topText,
       -font         => ['Times 14'],
       -height       => 2,
      )->pack(qw/-fill x/);

my $c  = $mw->Canvas(-bg     => '#CFCFCF',
             -width  => 500,
             -height => 400,
             )->pack;

my $id1 = $c->createRectangle(90, 190,
                  110, 210,
                  -fill    => $color,
                  -outline => $color,
                  );

my $id2 = $c->createRectangle(240, 190,
                  260, 210,
                  -fill    => $color,
                  -outline => $color,
                  );

my $id3 = $c->createRectangle(390, 190,
                  410, 210,
                  -fill    => $color,
                  -outline => $color,
                  );

my $chosen = ($id1, $id2, $id3)[rand 3];
my $arrow;
showArrow($chosen);

$c->bind($_, '<1>', [\&selectBox, $_]) for $id1, $id2, $id3;

my $msg = $c->createText(250, 300,
             -text    => '',
             -font    => ['Times 22 bold'],
             -justify => 'center',
             -fill    => 'red',
             -state   => 'hidden');

my $f = $mw->Frame->pack(qw/-fill x/);
$f->Label(-text         => 'Score: ')->pack(qw/-side left/);
$f->Label(-textvariable => \$score  )->pack(qw/-side left/);

$f->Button(-text   => 'Start',
       -bd     => 1,
       -height => 2,
       -padx   => 10,
       -command => sub {
         $c->itemconfigure($_, -state => 'hidden') for $arrow, $msg;

         for (1 .. 10) {
           my @ids = ($id1, $id2, $id3);
           my @s;
           push @s => splice @ids, int(rand @ids), 1 for 1 .. 2;
           rotate(@s, $delay[$score]);
         }
         $topText = "Click on the correct box.";
         $selFlag = 1;
       })->pack(qw/-side right/);

MainLoop;

sub rotate {
  my ($id1, $id2, $delay) = @_;

  my @c1 = $c->coords($id1);
  my @c2 = $c->coords($id2);

  my $mid1x = 0.5 * ($c1[2] + $c1[0]);
  my $mid1y = 0.5 * ($c1[3] + $c1[1]);
  my $mid2x = 0.5 * ($c2[2] + $c2[0]);
  my $mid2y = 0.5 * ($c2[3] + $c2[1]);

  #my $offx  = $mid1x > $mid2x ? $mid1x - $mid2x : $mid2x - $mid1x;
  #my $offy  = $mid1y > $mid2y ? $mid1y - $mid2y : $mid2y - $mid1y;
  my $offx = 0.5 * ($mid1x + $mid2x);
  my $offy = $mid1y;

  $_ -= $offx for $mid1x, $mid2x;
  $_ -= $offy for $mid1y, $mid2y;

  my $dir = rand > .5 ? 1 : -1;  # direction

  for (1 .. 18) {
    my $new1x = $mid1x * COS - $mid1y * $dir * SIN;
    my $new1y = $mid1y * COS + $mid1x * $dir * SIN;
    my $new2x = $mid2x * COS - $mid2y * $dir * SIN;
    my $new2y = $mid2y * COS + $mid2x * $dir * SIN;

    $mid1x = $new1x;
    $mid1y = $new1y;
    $mid2x = $new2x;
    $mid2y = $new2y;

    $c->coords($id1,
           $mid1x - 10 + $offx, $mid1y - 10 + $offy,
           $mid1x + 10 + $offx, $mid1y + 10 + $offy);
    $c->coords($id2,
           $mid2x - 10 + $offx, $mid2y - 10 + $offy,
           $mid2x + 10 + $offx, $mid2y + 10 + $offy);
    $c->update;

    $c->after($delay);
  }
}

sub showArrow {
  my $id = shift;

  unless (defined $arrow) {
    $arrow = $c->createLine(0, 0, 0, 0,
                -fill  => 'red',
                -arrow => 'last',
               );
  }

  my @c = $c->coords($id);

  my $x = 0.5 * ($c[2] + $c[0]);
  my $y = $c[1];

  $c->coords($arrow => $x, $y - 20,
         $x, $y - 5);

  $c->itemconfigure($arrow, -state => 'normal');
}

sub selectBox {
  return unless $selFlag;

  my $id = pop;

  if ($id == $chosen) {
    $score++;
    $c->itemconfigure($msg, -text => "That's Correct!\nScore: $score."
+);
  } else {
    $c->itemconfigure($msg, -text => "Wrong Answer!\nTry again.");
  }

  $c->itemconfigure($msg, -state => 'normal');
  showArrow($chosen);

  if ($score == 5) {
    $score = 0;
    $topText = "Reached maximum score!\nResetting score to 0.";
  } else {
    $topText = "Keep your eye on the indicated box.\nPress Start to pl
+ay.";
  }
  $selFlag = 0;
}

[tachyon]

Intersting. Minor bug. Press start button again while it is moving.....

[Chady]

and here's a patch for the start button

--- card.pl        2004-10-02 20:15:10.000000000 -0300
+++ fixed.pl       2004-10-02 20:14:51.000000000 -0300
@@ -7,6 +7,7 @@
 use constant COS => cos(3.14159265/18);
 
 my $color = 'darkolivegreen';
+my $rotating;
 my $score = 0;
 my @delay = (30,
             20,
@@ -68,6 +69,8 @@
           -height => 2,
           -padx   => 10,
           -command => sub {
+                  if (! $rotating) {
+                          $rotating = 1;
             $c->itemconfigure($_, -state => 'hidden') for $arrow, $ms
+g;
 
             for (1 .. 10) {
@@ -76,8 +79,11 @@
               push @s => splice @ids, int(rand @ids), 1 for 1 .. 2;
               rotate(@s, $delay[$score]);
             }
+            $rotating = 0;
             $topText = "Click on the correct box.";
             $selFlag = 1;
+                  }
+                  
           })->pack(qw/-side right/);
 
 MainLoop;

[zentara]

Hey, this would be perfect for a "sobriety test", maybe on a little LCD on the dashboard of a car. Easy enough to pass, but not after a few too many.