Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
PerlMonks  

Horse Race for linux!

by i5513 (Monk)
on Apr 01, 2012 at 23:14 UTC ( #962940=CUFP: print w/ replies, xml ) Need Help??

Hi Monks,

With AnyEvent and TermScreen modules, I would like to share with you a 100 lines script which emulate a race horse, I think it is funny :-).

#!/usr/bin/perl -w use strict; my $nhorses=10; my $finished=AnyEvent->condvar; require Term::Screen; use AnyEvent; sub status { my ($scr,$string) = @_; $scr->at ($nhorses,0)->clreol->reverse->bold->puts ("$string")->no +rmal; } sub next_step { my ($scr,$horses) = @_; my $max_jump=4; foreach my $horse (keys %$horses) { my $step=int(rand($max_jump)); $horses->{$horse}+=$step; if ($step == $max_jump-1 and (int (rand (20)) == 19)) { $horses->{$horse}+=$max_jump-1; status $scr, "Wowwww $horse went to infinity!!"; } } if (int(rand(10)) == 9) { status $scr, "Horses delayed: ". join (",", ((sort {$horses->{$a} <=> $horses->{$b}} keys %$horses)[0..2])); } } sub draw_horses { my ($scr,$horses) = @_; $scr-> at ( $_-1,$horses->{$_}-length $horses->{$_}+1)->puts($_) foreach sort { $a <=> $b } keys %$horses; } sub draw_end { my ($scr,$horses) = @_; $scr-> at ( $_-1,49)->puts("|") foreach keys %$horses; } sub clean_horses { my ($scr,$horses) = @_; $scr-> at ( $_-1, $horses->{$_}-length $horses->{$_}+1) -> puts(" " x length $_) foreach sort { $a <=> $b } keys %$hor +ses; } sub race_finished { my ($scr,$horses) = @_; my @winers = grep {$horses->{$_} > 50} (keys %$horses); if (scalar @winers > 0) { status $scr, "And the winner is: ". $winers[int(rand(scalar @winers))]."\r\n"; return 1; } return 0; } sub init_screen { my ($horses) = @_; my $scr = new Term::Screen; unless ($scr) { die "Something's wrong\n"; } $scr->clrscr(); system ("stty isig"); system ("tput civis"); draw_horses ($scr,$horses); draw_end ($scr, $horses); status $scr, "Ready ..."; sleep 1; status $scr, "Stady ..."; sleep + 1; status $scr, "Go! ..."; return $scr; } sub update_screen { my ($scr,$horses) = @_; clean_horses ($scr,$horses); next_step ($scr,$horses); draw_horses ($scr, $horses); $finished -> send if (scalar race_finished($scr,$horses)); } my $w = AnyEvent->signal (signal => "INT", cb => sub { system("tput cvvis"); print "Finished before the end\n"; exi +t 1 }); my %horses= map { $_ => 0 } (1..$nhorses); my $scr=init_screen (\%horses); my $hr = AnyEvent->timer (after => 2, interval => 1, cb => sub {update_screen ($scr,\%horses); }); $finished->recv;

I hope this script is ok for this section ... and other monks enjoy with the game. I even hacked an telnet server running that horse race using inet and IO::Socket::INET, but I cannot publish it online :-)

Could be many improvements to the game:

  • Allow bets
  • using festival if available
  • Adding ondemand telnet server
  • Rewrite without Term::Screen / AnyEvent dependencies ?

  • Please share your comments about the code if you see things done in the wrong way ! thanks!

    Regards,
    PD: It would be nice to see my patches https://rt.cpan.org/Public/Bug/Display.html?id=75858 and https://rt.cpan.org/Public/Bug/Display.html?id=75862 applied to Term::Screen module, so less tput / stty hacks have to be used.

    Comment on Horse Race for linux!
    Download Code
    Re: Horse Race for linux!
    by zentara (Archbishop) on Apr 02, 2012 at 09:48 UTC
        Greatful, thanks a lot, I will take a look to the code ! I get a seg fault, while horses are running, some races works fine some others not.
        $ LANG=C perl horses_gtk *** glibc detected *** perl: realloc(): invalid pointer: 0x&#65533;&#6 +5533;&#65533;3 *** *** unhandled exception in callback: *** `<span foreground="bl...' is not of type Gtk2::Widget at horses_ +gtk line 209. *** ignoring at horses_gtk line 228. Abortado (`core' generado) $ LANG=C perl horses_gtk Violación de segmento (`core' generado) $ file core core: ELF 64-bit LSB core file x86-64, version 1 (SYSV), SVR4-style, f +rom 'perl horses_gtk' $ ls -lh core -rw------- 1 user group 80M abr 2 15:36 core
          Thanks for the report. Its been a while since I tested it. I just ran it a few times myself, and am getting similar failures. I'll work at it and report any fixes I can find.

          Update: I believe it is a locking problem, as I try to lock a hash acting as a container variable, as in lock $track{$tr}{'go'};

          I was counting on each track to have it's own shared variable, so I thought locking would not be a problem. It didn't seem to matter on a single cpu computer, but now I have a multi-core computer, and it matters. Furthermore, I thought I could lock a portion of the shared hash container %track, but I read in perldoc threads::shared that it causes errors.

          From perldoc threads::shared: You cannot lock the individual elements of a container variable: my %hash :shared; $hash{'foo'} = 'bar'; #lock($hash{'foo'}); # Error lock(%hash); # Works If you need more fine-grained control over shared variable +access, see Thread::Semaphore.
          So it seems this code needs a re-write to make locking work.

          I'm not really a human, but I play one on earth.
          Old Perl Programmer Haiku ................... flash japh

    Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Node Status?
    node history
    Node Type: CUFP [id://962940]
    Approved by ww
    Front-paged by Arunbear
    help
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others having an uproarious good time at the Monastery: (3)
    As of 2015-05-28 02:41 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      In my home, the TV remote control is ...









      Results (548 votes), past polls