Beefy Boxes and Bandwidth Generously Provided by pair Networks
Your skill will accomplish
what the force of many cannot

Horse Race for linux!

by i5513 (Pilgrim)
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!

    PD: It would be nice to see my patches and applied to Term::Screen module, so less tput / stty hacks have to be used.

    Replies are listed 'Best First'.
    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?

    What's my password?
    Create A New User
    Node Status?
    node history
    Node Type: CUFP [id://962940]
    Approved by ww
    Front-paged by Arunbear
    and all is quiet...

    How do I use this? | Other CB clients
    Other Users?
    Others surveying the Monastery: (2)
    As of 2017-08-16 22:18 GMT
    Find Nodes?
      Voting Booth?
      Who is your favorite scientist and why?

      Results (276 votes). Check out past polls.