Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister

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: (3)
    As of 2018-01-20 15:54 GMT
    Find Nodes?
      Voting Booth?
      How did you see in the new year?

      Results (227 votes). Check out past polls.