Beefy Boxes and Bandwidth Generously Provided by pair Networks
Think about Loose Coupling
 
PerlMonks  

RFC: Language::Logo

by liverpole (Monsignor)
on Jan 30, 2007 at 04:24 UTC ( #597268=perlmeditation: print w/ replies, xml ) Need Help??

Greeting fellow monks,

At the beginning of this month, I started working on a new Perl project, whose goal was to implement the Logo programming language (also known as "turtle graphics").

I had never actually programmed in Logo myself, but thought it would be fun to combine all of the low-level Logo commands for doing drawing (in a Perl/Tk GUI) with the power of Perl to do the rest.  (At some point in the future, I plan to implement more of the Logo programming language itself, including loop constructs, conditionals, subroutines, etc.)

One of the biggest early hurdles was getting past the well-known fact that you can't do Tk within a child thread.  But I wanted to create a Tk window automatically whenever the first Logo object was constructed, and I didn't want the user to have to manage the event loop themselves.  A coworker suggested forking off a separate instance of the Perl interpreter as a server, and having it respond to requests over a socket, and once I had that working, the rest was a lot more fun!

One of the "cool" aspects of using a client-server model for the project was that I'm no longer limited to a single "turtle" on the screen; the module supports multiple simultaneous clients.  Additionally, since there is support for quering any particular client's parameters (including screen position, angle heading, etc.), there is some interesting potential for possible games or projects which could result (Light cycles, for example).

The following code represents the Language::Logo module, which I'm planning to submit (as my first module) to CPAN.  On January 16th, I gave a presentation to Boston Perl Mongers, and was given some good feedback (including the appropriate namespace under which to register:  Language::Logo).  But I'd also like to hear comments from my fellow Perl monks, whose opinions I hold in high regard.  So please give me your feedback!

Here is the current code for Language::Logo:

# # Language::Logo.pm # # An implementation of the Logo programming language which allows # multiple clients to connect simultaneously. # # Written January 2007, by John C. Norton # Presented at Boston Perlmongers on January 16th, 2007 # # Package header package Logo; our $VERSION = '1.000'; # Current version # Strict use strict; use warnings; # Libraries use IO::Select; use IO::Socket; use Sys::Hostname; ################# ### Variables ### ################# use constant PI => (4 * atan2(1, 1)); # User-defined my $date = '070129'; # Date last modified my $iam = "Language::Logo"; # Module identifier my $d_title = "$iam version $VERSION"; my $max_connect = 16; # Maximum client connections my $retry_timeout = 10; # Client connection timeout after N se +conds # Defaults my $d_port = "8220"; # Default socket port my $d_update = 10; # Default gui update rate my $d_bg = "black"; # Default canvas background color my $d_width = 512; # Default canvas width my $d_height = 512; # Default canvas height my $d_color = 'white'; # Default pen/turtle color my $d_psize = '1'; # default pen size (thickness) my $d_txdim = '6'; # Default turtle x-dimension my $d_tydim = '9'; # Default turtle y-dimension my @switches = qw( name debug title bg width height update host por +t ); my %switches = map { $_ => 1 } @switches; # Client-specific top-level variables (with initial values) my $pvars = { 'debug' => 0, 'step' => 0, 'wrap' => 0, }; # Command aliases my $palias = { 'fd' => 'forward', 'bk' => 'backward', 'rt' => 'right', 'lt' => 'left', 'sh' => 'seth', 'pu' => 'penup', 'pd' => 'pendown', 'ps' => 'pensize', 'co' => 'color', 'cs' => 'clear', 'hm' => 'home', 'sx' => 'setx', 'sy' => 'sety', 'xy' => 'setxy', 'ht' => 'hideturtle', 'st' => 'showturtle', 'w' => 'width', 'h' => 'height', 'ud' => 'update', 'bg' => 'background', }; my $pmethods = { 'forward' => 'move_turtle', 'backward' => 'move_turtle', 'right' => 'turn_turtle', 'left' => 'turn_turtle', 'seth' => 'turn_turtle', 'penup' => 'change_pen_state', 'pendown' => 'change_pen_state', 'pensize' => 'change_pen_size', 'color' => 'change_color', 'clear' => 'modify_canvas', 'width' => 'modify_canvas', 'height' => 'modify_canvas', 'background' => 'modify_canvas', 'home' => 'reset_turtle', 'setx' => 'move_turtle', 'sety' => 'move_turtle', 'setxy' => 'move_turtle', 'hideturtle' => 'show_turtle', 'showturtle' => 'show_turtle', 'update' => 'change_update', }; ################### ### Subroutines ### ################### #=================== #=== Client code === #=================== sub new { my ($class, @args) = @_; (ref $class) and $class = ref $class; # Create blessed reference my $self = { }; bless $self, $class; # Parse optional arguments while (@args) { my $arg = shift @args; if ($arg =~ /^sig(.+)$/) { # Trap specified signals my $sig = uc $1; $SIG{$sig} = shift @args; } elsif (defined($switches{$arg}) and @args > 0) { # Assign all valid parameters $self->{$arg} = shift @args; } } # Startup a new server locally if 'host' was not defined. if (!defined($self->{'host'})) { $self->fork_server(); } # Connect to the server $self->connect_to_server(); # Return the object return $self; } sub disconnect { my ($self, $msg) = @_; if ($msg || 0) { print "$msg"; <STDIN>; } my $sock = $self->{'socket'}; if ($sock || 0) { close($sock); } } sub connect_to_server { my ($self) = @_; # Return if socket is already connected my $sock = $self->{'socket'} || 0; my $name = $self->{'name'} || ""; $sock and return $sock; # If hostname is ':', use local host my $host = $self->{'host'} || ':'; ($host eq ':') and $host = hostname(); my $port = $self->{'port'} || $d_port; my %params = ( 'PeerAddr' => $host, 'PeerPort' => $port, 'Proto' => 'tcp', 'ReuseAddr' => 1, ); # Keep retrying until $retry_timeout is exceeded my $start = time; while (1) { ($sock = new IO::Socket::INET(%params)) and last; # Success! if (time - $start > $retry_timeout) { die "$iam: Failed client socket connection\n"; } select(undef, undef, undef, 0.1); } # Save socket $self->{'socket'} = $sock; print $sock ":$name\n"; chomp(my $ans = <$sock>); if ($ans !~ /^(\d+):(.+)$/) { die "$iam: expected 'id:name', got '$ans'\n"; } my ($id, $newname) = ($1, $2); $self->{'id'} = $id; $self->{'name'} = $newname; $self->{'host'} = $host; return $sock; } sub host { my ($self) = @_; return $self->{'host'}; } sub interact { my ($self) = @_; print "Type '?' for help\n"; while (1) { print "$iam> "; my $cmd = <STDIN>; defined($cmd) or return; chomp $cmd; $cmd =~ s/^\s*(.*)\s*$/$1/; ($cmd eq 'quit' or $cmd eq 'bye' or $cmd eq 'exit') and return +; if ($cmd ne "") { if ($cmd =~ s/^\?//) { my $ans = $self->ask($cmd); print "Response: $ans\n"; } else { my $ans = $self->command($cmd); $ans and print "Command ERROR: $ans\n"; } } } } sub command { my ($self, $cmdstr) = @_; my $sock = $self->connect_to_server(); $sock or return 0; my @commands = split(';', $cmdstr); foreach my $cmd (@commands) { print $sock "=$cmd\n"; my $answer = <$sock>; $answer or die "$iam: server socket went away\n"; chomp $answer; $answer and return $answer; } return ""; } sub cmd { my $self = shift; return $self->command(@_); } sub query { my ($self, $cmd) = @_; my $sock = $self->connect_to_server(); $sock or return 0; print $sock "?$cmd\n"; chomp(my $answer = <$sock>); return $answer; } sub ask { my $self = shift; return $self->query(@_); } #=================== #=== Server code === #=================== sub fork_server { my ($self) = @_; my $b_dbg = $self->{'debug'} || 0; my $title = $self->{'title'} || $d_title; my $w = $self->{'width'} || $d_width; my $h = $self->{'height'} || $d_height; my $bg = $self->{'bg'} || $d_bg; my $update = $self->{'update'} || $d_update; my $host = $self->{'host'} || hostname(); my $port = $self->{'port'} || $d_port; my $fork = fork(); defined($fork) or die "$iam: failed to fork server\n"; $fork and return; Logo->server_init($b_dbg, $title, $w, $h, $bg, $update, $host, $po +rt); } sub server_init { my ($class, $b_dbg, $title, $w, $h, $bg, $update, $host, $port) = +@_; # Create a blessed object my $self = { 'nticks' => 0, # Tracks number of GUI updates 'debug' => $b_dbg, # Debug flag 'count' => 0, # Current number of connections 'total' => 0, # Total number of connections 'clients' => { }, # The client hash 'names' => { }, # The clients by name }; bless $self, $class; # Open a socket connection at the desired port my %params = ( 'LocalHost' => $host, 'LocalPort' => $port, 'Proto' => 'tcp', 'Listen' => $max_connect, 'ReuseAddr' => 1, ); # Create socket object my $sock = new IO::Socket::INET(%params); if (!$sock) { # Port is already in use -- client will connect to it instead $b_dbg and print "[Port $port already in use]\n"; exit; } $self->{'socket'} = $sock; # Create select set for reading $self->{'select'} = new IO::Select($sock); # Create the GUI require Tk; $b_dbg and print "[Logo server v$VERSION on '$host']\n"; my $mw = Tk::MainWindow->new(-title => $title); $self->{'mw'} = $mw; # Allow easy dismissal of the GUI $mw->bind("<Escape>" => sub { $self->server_exit }); # Create a new canvas $self->clear_screen($w, $h, $bg); # Manage the GUI $self->{'repid'} = $self->set_update($update); Tk::MainLoop(); } sub server_exit { my ($self) = @_; my $mw = $self->{'mw'}; my $sel = $self->{'select'}; my $sock = $self->{'socket'}; my $pclients = $self->{'clients'}; my $pnames = $self->{'names'}; close $sock; foreach my $name (keys %$pnames) { my $pclient = $pnames->{$name}; my $fh = $pclient->{'fh'}; $self->server_remove_client($pclients, $sel, $fh); } # Shouldn't ever get here, since when the last client exited, # the server should have already gone away. But just in case ... # $mw->destroy(); exit; } sub set_update { my ($self, $update) = @_; ($update < 1) and $update = 1; ($update > 1000) and $update = 1000; $self->{'update'} = $update; my $mw = $self->{'mw'}; my $id = $mw->repeat($update => sub { $self->server_loop() }); return $id; } sub server_loop { my ($self) = @_; # Increment tick count ++$self->{'nticks'}; # Get data from the object my $sel = $self->{'select'}; my $sock = $self->{'socket'}; my $pclients = $self->{'clients'}; # Handle each pending socket my @readable = $sel->can_read(0); foreach my $rh (@readable) { if ($rh == $sock) { # The main socket means a new incoming connection. $self->server_add_client($rh, $pclients); } else { # Service the socket my $text = <$rh>; if (defined($text)) { # Process packet (either command or ask) chomp $text; my $pc = $pclients->{$rh}; $self->server_socket_input($pc, $text); } else { # Socket was closed -- remove the client $self->server_remove_client($pclients, $sel, $rh); } } } } sub server_add_client { my ($self, $rh, $pclients) = @_; # Accept the client connect and add the new socket my $sel = $self->{'select'}; my $ns = $rh->accept(); $sel->add($ns); my $b_dbg = $self->{'debug'} || 0; my $peer = getpeername($ns); my ($port, $iaddr) = unpack_sockaddr_in($peer); my $remote = inet_ntoa($iaddr); # Get the client handshake, and send back its unique ID chomp(my $text = <$ns>); ($text =~ /^:(.*)$/) or die "Bad header, expected ':[name]', got ' +$text'"; my $name = $1 || ""; my $id = $self->{'total'} + 1; $name ||= "CLIENT$id"; print $ns "$id:$name\n"; my $pc = $pclients->{$ns} = { 'id' => $id, 'fh' => $ns, 'name' => $name, 'remote' => $remote, }; # Create the 'turtle' object $self->create_turtle($pc); # Increment the number of connections and the total connection cou +nt ++$self->{'count'}; ++$self->{'total'}; # Add the client's name $b_dbg and print "[Added socket $id => '$name']\n"; $self->{'names'}->{$name} = $pclients->{$ns}; } sub server_remove_client { my ($self, $pclients, $sel, $fh) = @_;; my $b_dbg = $self->{'debug'} || 0; my $pc = $pclients->{$fh}; my $name = $pc->{'name'}; my $id = $pc->{'id'}; $sel->remove($fh); close($fh); delete $pclients->{$fh}; # Remove the client's name my $pnames = $self->{'names'}; delete $pnames->{$name}; # Remove the client's turtle my $cv = $self->{'canvas'}; my $ptids = $pc->{'turtle'}->{'tids'}; ($ptids || 0) and map { $cv->delete($_) } @$ptids; # Decrement the global client count --$self->{'count'}; $b_dbg and print "[Closed socket $id '$name']\n"; # Exit the server if this is the last connection if (0 == $self->{'count'} and $self->{'total'} > 0) { $b_dbg and print "[Final client closed -- exiting]\n"; $self->{'mw'}->destroy(); exit; } } sub server_socket_input { my ($self, $pc, $cmd) = @_; my $mode = $pc->{'mode'}; ($cmd =~ s/^=\s*//) and return $self->server_command($pc, $cmd); ($cmd =~ s/^\?\s*//) and return $self->server_query($pc, $cmd); } sub server_command { my ($self, $pc, $cmdstr) = @_; my $id = $pc->{'id'}; $pc->{'lastcmd'} = $cmdstr; $pc->{'debug'} and print "Command<$id>: '$cmdstr'\n"; my @args = split(/\s+/, $cmdstr); my $cmd = shift @args; # Resolve any command alias while (defined($palias->{$cmd})) { my $newcmd = $palias->{$cmd}; $cmd = $newcmd; } unshift @args, $cmd; # Execute one command if single-stepping is on if ($pc->{'step'}) { my $go = $self->single_step_prompt($pc, $cmd, [ @args ]); $go or return $self->server_reply($pc); } # Variables if (defined($pvars->{$cmd})) { return $self->set_variable($pc, @args); } # Find command in dispatch table my $method = $pmethods->{$cmd}; defined($method) and return $self->$method($pc, @args); # Return acknowledgment $self->server_reply($pc, "Unknown command '$cmd'"); } sub single_step_prompt { my ($self, $pc, $cmd, $pargs) = @_; my $cmdstr = join(" ", @$pargs); print "Step> [$cmdstr] Execute {y|n|c}? [y]"; chomp(my $ans = <STDIN>); ($ans =~ /^[cC]/) and $pc->{'step'} = 0; return ($ans =~ /^[nN]/)? 0: 1; } sub server_reply { my ($self, $pc, $reply) = @_; my $fh = $pc->{'fh'}; $reply ||= ""; print $fh "$reply\n"; } sub server_query { my ($self, $pc, $cmd) = @_; my $id = $pc->{'id'}; $pc->{'debug'} and print "Request<$id>: '$cmd'\n"; my @args = split(/\s+/, $cmd); $cmd = shift @args; my $cv = $self->{'canvas'}; # Quit if the query contains no text ($cmd || 0) or return $self->server_reply($pc, "Blank query"); # Return the specified global parameter, if defined if (defined($self->{$cmd})) { return $self->server_reply($pc, $self->{$cmd}); } # Return the specified per-client parameter, if defined if (defined($pc->{$cmd})) { return $self->server_reply($pc, $pc->{$cmd}); } # Return the specified per-client turtle parameter, if defined my $turtle = $pc->{'turtle'}; if (defined($turtle->{$cmd})) { return $self->server_reply($pc, $turtle->{$cmd}); } # Return an error message my $ans = "Unknown query '$cmd'"; $self->server_reply($pc, $ans); } sub create_turtle { my ($self, $pc, $from) = @_; my $turtle = { 'step' => 0, # Single step flag 'pen' => 0, # Pen state: 0 = 'up', 1 = 'down' 'color' => $d_color, # Pen color (also turtle color) 'size' => $d_psize, # Pen size (thickness) 'xdim' => $d_txdim, # Turtle x-dimension 'ydim' => $d_tydim, # Turtle y-dimension 'dist' => 0, # Last distance traveled (used as defa +ult) 'show' => 1, # Turtle starts out visible }; # Use old turtle as a reference if ($from || 0) { map { $turtle->{$_} = $from->{$_} } (keys %$from); } $self->home_turtle($pc, $turtle); $self->draw_turtle($pc, $turtle); } sub home_turtle { my ($self, $pc, $turtle) = @_; my $cv = $self->{'canvas'}; my $width = $cv->cget(-width); my $height = $cv->cget(-height); my $x = int($width / 2); my $y = int($height / 2); $turtle->{'x'} = $x; $turtle->{'y'} = $y; $turtle->{'angle'} = 0; } sub reset_turtle { my ($self, $pc, $cmd) = @_; my $turtle = $pc->{'turtle'}; $self->home_turtle($pc, $turtle); $self->draw_turtle($pc, $turtle); $self->server_reply($pc); } sub draw_turtle { my ($self, $pc, $turtle) = @_; # Erase old turtle if one exists my $cv = $self->{'canvas'}; my $ptids = $pc->{'turtle'}->{'tids'}; if ($ptids || 0) { map { $cv->delete($_) } @$ptids; $pc->{'turtle'}->{'tids'} = 0; } # Create turtle parameters my $cvbg = $cv->cget(-bg); my $x = $turtle->{'x'}; my $y = $turtle->{'y'}; my $xdim = $turtle->{'xdim'}; my $ydim = $turtle->{'ydim'}; my $color = $turtle->{'color'}; my $angle = $turtle->{'angle'}; my $show = $turtle->{'show'}; if ($turtle->{'show'}) { # Assign points, rotate them, and plot the turtle my $ppts = [ $x, $y, $x-$xdim, $y, $x, $y-2*$ydim, $x+$xdim, $ +y ]; $ppts = $self->rotate($x, $y, $angle, $ppts); my @args = (-fill => $cvbg, -outline => $color); my $tid = $cv->createPolygon(@$ppts, @args); $turtle->{'tids'} = [ $tid ]; $pc->{'turtle'} = $turtle; # If the pen is down, draw a circle around the current point $ppts = [ ]; if ($turtle->{'pen'}) { $ppts = [ $x-3, $y-3, $x+3, $y+3 ]; $tid = $cv->createOval(@$ppts, -outline => $color); push @{$turtle->{'tids'}}, $tid; } } # Save the turtle to this client's data $pc->{'turtle'} = $turtle; } sub change_update { my ($self, $pc, $cmd, $update) = @_; my $repid = $self->{'repid'}; ($repid || 0) and $repid->cancel(); $self->{'repid'} = $self->set_update($update); $self->server_reply($pc); } sub set_variable { my ($self, $pc, $param, $val) = @_; $pc->{$param} = $val || 0; $pc->{'debug'} and print "Variable '$param' set to '$val'\n"; $self->server_reply($pc); } sub modify_canvas { my ($self, $pc, $cmd, $val) = @_; my $cv = $self->{'canvas'}; ($cmd eq 'clear') and $self->clear_screen(); ($cmd eq 'width') and eval {$cv->configure('-wi', $val || $d_ +width)}; ($cmd eq 'height') and eval {$cv->configure('-he', $val || $d_ +height)}; ($cmd eq 'background') and eval {$cv->configure('-bg', $val || $d_ +bg)}; my $pnames = $self->{'names'}; foreach my $name (keys %$pnames) { my $pclient = $pnames->{$name}; my $turtle = $pclient->{'turtle'}; if ($cmd eq 'w' or $cmd eq 'h') { # Have to recreate the turtle $self->create_turtle($pclient); } elsif ($cmd eq 'bg') { # Have to redraw the turtle $self->draw_turtle($pclient, $turtle); } } $self->server_reply($pc); } sub clear_screen { my ($self, $width, $height, $bg) = @_; # Clear any old canvas my $oldcv = $self->{'canvas'}; if ($oldcv || 0) { $width ||= $oldcv->cget(-width); $height ||= $oldcv->cget(-height); $bg ||= $oldcv->cget(-bg); $oldcv->packForget(); } # Create a new canvas $width ||= $d_width; $height ||= $d_height; $bg ||= $d_bg; my $mw = $self->{'mw'}; my @opts = (-bg => $bg, -width => $width, -height => $height); my $cv = $mw->Canvas(@opts); $cv->pack(-expand => 1, -fill => 'both'); $self->{'canvas'} = $cv; # For each client, draw its turtle my $pclients = $self->{'clients'} || { }; foreach my $pc (values %$pclients) { my $turtle = $pc->{'turtle'}; $self->create_turtle($pc, $turtle); } } sub rotate { my ($self, $x, $y, $angle, $ppoints) = @_; for (my $i = 0; $i < @$ppoints; $i += 2) { $ppoints->[$i] -= $x; $ppoints->[$i+1] -= $y; } my $ppolar = $self->rect_to_polar($ppoints); for (my $i = 1; $i <= @$ppolar; $i += 2) { $ppolar->[$i] = ($ppolar->[$i] + $angle) % 360; } $ppoints = $self->polar_to_rect($ppolar); for (my $i = 0; $i < @$ppoints; $i += 2) { $ppoints->[$i] += $x; $ppoints->[$i+1] += $y; } return $ppoints; } sub calculate_endpoint { my ($self, $x, $y, $angle, $dist) = @_; my $prect = $self->polar_to_rect([ $dist, $angle ]); my ($x1, $y1) = @$prect; $x1 += $x; $y1 += $y; return ($x1, $y1); } sub rect_to_polar { my ($self, $ppoints) = @_; my $ppolar = ( ); while (@$ppoints > 1) { my $x = shift @$ppoints; my $y = shift @$ppoints; my $r = sqrt($x ** 2 + $y ** 2); my $t = $self->rad_to_deg(atan2($y, $x)); push @$ppolar, $r, $t; } return $ppolar; } sub polar_to_rect { my ($self, $ppoints) = @_; my $prect = [ ]; while (@$ppoints > 1) { my $r = shift @$ppoints; my $t = $self->deg_to_rad(shift @$ppoints); my $x = $r * cos($t); my $y = $r * sin($t); push @$prect, $x, $y; } return $prect; } sub deg_to_rad { my ($self, $degrees) = @_; my $radians = $degrees * PI / 180; ($radians < 0) and $radians += 6.283185307; return $radians; } sub rad_to_deg { my ($self, $radians) = @_; my $degrees = $radians * 180 / PI; ($degrees < 0) and $degrees += 360; return $degrees; } sub show_turtle { my ($self, $pc, $cmd) = @_; my $b_show = ($cmd eq 'st')? 1: 0; my $turtle = $pc->{'turtle'}; $turtle->{'show'} = $b_show; $self->draw_turtle($pc, $turtle); $self->server_reply($pc); } sub change_color { my ($self, $pc, $cmd, $color) = @_; defined($color) or return $self->syntax_error($pc); # Allow a random color if (($color || "") eq 'random') { $color = sprintf "#%02x%02x%02x", rand 256, rand 256, rand 256 +; } my $turtle = $pc->{'turtle'}; $turtle->{'color'} = $color; $self->draw_turtle($pc, $turtle); $self->server_reply($pc); } sub change_pen_state { my ($self, $pc, $cmd) = @_; my $state = ($cmd eq 'pendown')? 1: 0; my $turtle = $pc->{'turtle'}; $turtle->{'pen'} = $state; $self->draw_turtle($pc, $turtle); $self->server_reply($pc); } sub change_pen_size { my ($self, $pc, $cmd, $size, @args) = @_; my $turtle = $pc->{'turtle'}; # Allow a random pen size if (($size || "") eq "random") { my $min = $args[0]; my $max = $args[1]; defined($min) or return $self->syntax_error($pc); defined($max) or return $self->syntax_error($pc); $size = $min + rand($max - $min); } $size ||= $d_psize; $turtle->{'size'} = $size; $self->server_reply($pc); } sub syntax_error { my ($self, $pc) = @_; my $cmd = $pc->{'lastcmd'}; $self->server_reply($pc, "syntax error in '$cmd'"); } sub turn_turtle { my ($self, $pc, $cmd, $newang, $arg0, $arg1) = @_; my $turtle = $pc->{'turtle'}; my $angle = $turtle->{'angle'}; # Allow a random angle of turn if (($newang || "") eq 'random') { defined($arg0) or return $self->syntax_error($pc); defined($arg1) or return $self->syntax_error($pc); $newang = $arg0 + rand($arg1 - $arg0); } # Make angles default to right angles defined($newang) or $newang = 90; # Assign the angle ($cmd eq 'left') and $angle = $angle - $newang; ($cmd eq 'right') and $angle = $angle + $newang; ($cmd eq 'seth') and $angle = $newang; # Normalize the angle while ($angle < 0) { $angle += 360 } while ($angle > 360) { $angle -= 360 } $turtle->{'angle'} = $angle; $self->draw_turtle($pc, $turtle); $self->server_reply($pc); } sub move_turtle { my ($self, $pc, $cmd, $dist, $arg0, $arg1) = @_; my $wrap = $pc->{'wrap'} || 0; my $turtle = $pc->{'turtle'}; my $angle = $turtle->{'angle'}; # Allow a random distance if (($dist || "") eq 'random') { defined($arg0) or return $self->syntax_error($pc); defined($arg1) or return $self->syntax_error($pc); $dist = $arg0 + rand($arg1 - $arg0); } $dist ||= $turtle->{'dist'}; (0 == $dist) and $self->syntax_error($pc); $turtle->{'dist'} = $dist; ($cmd eq 'forward') and $angle = ($angle + 270) % 360; ($cmd eq 'backward') and $angle = ($angle + 90) % 360; my ($x0, $y0) = ($turtle->{'x'}, $turtle->{'y'}); my ($x1, $y1); if ($cmd eq 'setx' or $cmd eq 'sety' or $cmd eq 'setxy') { if ($cmd eq 'setxy') { defined($dist) or return $self->syntax_error($pc); defined($arg0) or return $self->syntax_error($pc); ($x1, $y1) = ($dist, $arg0); } else { defined($dist) or return $self->syntax_error($pc); ($x1, $y1) = ($x0, $y0); ($x1, $y1) = ($cmd eq 'setx')? ($dist, $y0): ($x0, $dist); } } else { ($x1, $y1) = $self->calculate_endpoint($x0, $y0, $angle, $dist +); } my @args = ($pc, $x0, $y0, $x1, $y1); return $self->move_turtle_reflect(@args) if (2 == $wrap); return $self->move_turtle_torus(@args) if (1 == $wrap); return $self->move_turtle_normal(@args); # Assume wrap == 0 } sub move_turtle_normal { my ($self, $pc, $x0, $y0, $x1, $y1) = @_; my $turtle = $pc->{'turtle'}; my $pen = $turtle->{'pen'}; my $size = $turtle->{'size'}; my $color = $turtle->{'color'}; $self->line($pen, $x0, $y0, $x1, $y1, $color, $size); $self->move($pc, $x1, $y1); return $self->server_reply($pc); } sub move_turtle_torus { my ($self, $pc, $x0, $y0, $x1, $y1) = @_; my $turtle = $pc->{'turtle'}; my $pen = $turtle->{'pen'}; my $size = $turtle->{'size'}; my $color = $turtle->{'color'}; # Calculate (dx, dy), which don't change for torus behavior my ($dx, $dy) = ($x1 - $x0, $y1 - $y0); while (!$self->contained($x1, $y1)) { my $height = $self->{'height'}; my $width = $self->{'width'}; if (abs($dx) < 0.0000001) { # Vertical line my $yb = ($y1 < $y0)? 0: $height; $self->line($pen, $x0, $y0, $x0, $yb, $color, $size); ($y0, $y1) = $yb? (0, $y1-$height): ($height, $y1+$height) +; $self->move($pc, $x0, $y0); } elsif (abs($dy) < 0.0000001) { # Horizontal line my $xb = ($x1 < $x0)? 0: $width; $self->line($pen, $x0, $y0, $xb, $y0, $color, $size); ($x0, $x1) = $xb? (0, $x1-$width): ($width, $x1+$width); $self->move($pc, $x0, $y0); } else { # Diagonal line my $m = $dy / $dx; my $b = $y1 - ($m * $x1); my $xb = ($y1 > $y0)? (($height - $b) / $m): (-$b / $m); my $yb = ($x1 > $x0)? (($m * $width) + $b): $b; my ($xn, $yn) = ($xb, $yb); my $crossx = ($xb > 0 and $xb < $width)? 1: 0; my $crossy = ($yb > 0 and $yb < $height)? 1: 0; if ($crossx and !$crossy) { # Line intercepts x-axis $yb = ($y1 > $y0)? $height: 0; $yn = $height - $yb; $y1 = ($y1 > $y0)? $y1 - $height: $y1 + $height; } elsif ($crossy and !$crossx) { # Line intercepts y-axis $xb = ($x1 > $x0)? $width: 0; $xn = $width - $xb; $x1 = ($x1 > $x0)? $x1 - $width: $x1 + $width; } else { # Line intercepts both axes $xb = ($x1 > $x0)? $width: 0; $yb = ($y1 > $y0)? $height: 0; ($xn, $yn) = ($width - $xb, $height - $yb); $x1 = ($x1 > $x0)? $x1 - $width: $x1 + $width; $y1 = ($y1 > $y0)? $y1 - $height: $y1 + $height; } $self->line($pen, $x0, $y0, $xb, $yb, $color, $size); ($x0, $y0) = ($xn, $yn); $self->move($pc, $x0, $y0); } } # Back within canvas return $self->move_turtle_normal($pc, $x0, $y0, $x1, $y1); } sub move_turtle_reflect { my ($self, $pc, $x0, $y0, $x1, $y1) = @_; my $turtle = $pc->{'turtle'}; my $angle = $turtle->{'angle'}; my $pen = $turtle->{'pen'}; my $size = $turtle->{'size'}; my $color = $turtle->{'color'}; while (!$self->contained($x1, $y1)) { # Calculate (dx, dy), which change for reflection behavior my ($dx, $dy) = ($x1 - $x0, $y1 - $y0); my $height = $self->{'height'}; my $width = $self->{'width'}; if (abs($dx) < 0.0000001) { # Vertical line my $yb = ($y1 < $y0)? 0: $height; $self->line($pen, $x0, $y0, $x0, $yb, $color, $size); $y0 = $yb; $y1 = ($y1 < $y0)? (- $y1): (2 * $height) - $y1; $self->move($pc, $x0, $y0); $angle = $self->adjust_angle($pc, 180 - $angle); } elsif (abs($dy) < 0.0000001) { # Horizontal line my $xb = ($x1 < $x0)? 0: $width; $self->line($pen, $x0, $y0, $xb, $y0, $color, $size); $x0 = $xb; $x1 = ($x1 < $x0)? (- $x1): (2 * $width) - $x1; $self->move($pc, $x0, $y0); $angle = $self->adjust_angle($pc, 360 - $angle); } else { # Diagonal line my $m = $dy / $dx; my $b = $y1 - ($m * $x1); my $xb = ($y1 > $y0)? (($height - $b) / $m): (-$b / $m); my $yb = ($x1 > $x0)? (($m * $width) + $b): $b; my $crossx = ($xb > 0 and $xb < $width)? 1: 0; my $crossy = ($yb > 0 and $yb < $height)? 1: 0; if ($crossx and !$crossy) { # Line intercepts x-axis $yb = ($y1 > $y0)? $height: 0; $y1 = ($y1 > $y0)? (2 * $height - $y1): (- $y1); } elsif ($crossy and !$crossx) { # Line intercepts y-axis $xb = ($x1 > $x0)? $width: 0; $x1 = ($x1 > $x0)? (2 * $width - $x1): (- $x1); } else { # Line intercepts both axes $xb = ($x1 > $x0)? $width: 0; $yb = ($y1 > $y0)? $height: 0; $x1 = ($x1 > $x0)? (2 * $width - $x1): (- $x1); $y1 = ($y1 > $y0)? (2 * $height - $y1): (- $y1); } $self->line($pen, $x0, $y0, $xb, $yb, $color, $size); ($x0, $y0) = ($xb, $yb); $self->move($pc, $x0, $y0); $angle = $self->adjust_angle($pc, 180 - $angle); } } # Back within canvas return $self->move_turtle_normal($pc, $x0, $y0, $x1, $y1); } sub adjust_angle { my ($self, $pc, $newang) = @_; my $turtle = $pc->{'turtle'}; while ($newang >= 360) { $newang -= 360; } while ($newang < 0) { $newang += 360; } $turtle->{'angle'} = $newang; $self->draw_turtle($pc, $turtle); return $newang; } sub line { my ($self, $pen, $x0, $y0, $x1, $y1, $color, $size) = @_; # Pen is up; no need to draw return unless $pen; # Get canvas and draw line my $cv = $self->{'canvas'}; my @points = ($x0, $y0, $x1, $y1, -fill => $color, -width => $size +); $cv->createLine(@points); } sub move { my ($self, $pc, $x, $y) = @_; # Set new turtle coordinates and redraw turtle my $turtle = $pc->{'turtle'}; $turtle->{'x'} = $x; $turtle->{'y'} = $y; $self->draw_turtle($pc, $turtle); } sub contained { my ($self, $x1, $y1) = @_; my $cv = $self->{'canvas'}; my $width = $cv->cget(-width); my $height = $cv->cget(-height); $self->{'width'} = $width; $self->{'height'} = $height; return ($x1 < 0 or $x1 > $width or $y1 < 0 or $y1 > $height)? 0: 1 +; } 1; __END__ =head1 NAME Language::Logo - An implementation of the Logo programming language =head1 SYNOPSIS use Language::Logo; my $lo = new Logo(update => 20); $lo->command("setxy 250 256"); $lo->command("color yellow"); $lo->command("pendown"); # Draw a circle for (my $i = 0; $i < 360; $i += 10) { $lo->command("forward 10; right 10"); } $lo->disconnect("Finished...") =head1 DESCRIPTION This module provides an implementation of the Logo programming languag +e, with all of the necessary drawing primitives in a Tk Canvas. The Canvas ob +ject is also referred to as the "screen". The first construction of a Language::Logo object causes a server to b +e created in a separate process; this server then creates a Tk GUI with +a Tk::Canvas for use by the client's "turtle", and responds to all reque +sts from the client's commands. In this way, multiple clients may be cons +tructed simultaneously -- each one with its own "turtle". In this first release, not all of the Logo language is implemented. Rather, the primary commands available are those which directly affect the turtle, and are related to drawing on the screen. The intent is t +o use the Logo in conjunction with Perl as a sort of "hybrid" language; Perl us used as the higher-level language layer through which all loop constructs, conditionals, and data-manipulation is done. This allows for a substantial level of programming power. =head2 Methods =over 4 =item I<PACKAGE>->new([I<param> => I<value>, [I<param> => I<value>, .. +.]]) Returns a newly created C<Language::Logo> object. No arguments are re +quired, but the following are allowed (each of which must be accompanied by a +value): =item name I<client name> the name of the current client. (The default is a uniquely generated +name; this parameter is not currently used, but may be used in the future to + force synchronization between clients in a multiple-client scenario). =item debug I<0 or 1> a zero value turns debugging off (the default); a nonzero value turns debugging on. =item title I<main window title> the title of the Tk window (the default is the name and current versio +n number of the module). =item bg I<background color> the starting background color of the screen (the default is black). =item width I<screen width> the starting width of the screen (the default is 512 pixels). =item height I<screen height> the starting height of the screen (the default is 512 pixels). =item update I<update interval> the starting update value for controlling the number of milliseconds t +o delay before reentering Tk's idle loop. The fastest is therefore a va +lue of 1 (which updates up to 1000 times per second). =item host I<server address> the host computer where the server is running (the default is to use t +he server on the local machine). If the host is on a remote machine, it +is assumed that the remote machine has already constructed at least one Language::Logo object which is currently running its own local server. =item port I<server port> the port at which to connect to the server (the default is port 8220). =back =item I<$OBJ>->disconnect([I<message>]) =over 4 Disconnects from the server. If a message is supplied, the user is prompted with the message, and the program waits until a newline is typed before disconnecting. This is especially useful if the client is the only one (or last one) connected; in which case the server will also exit upon disconnect. =item I<$OBJ>->interact() Enters interactive mode, whereby the user can issue Logo commands one-at-a-time. Queries may also be used to retrieve various informati +on about the state of the current client's object. =item I<$OBJ>->query(I<parameter>) =item I<$OBJ>->ask(I<parameter>) Queries the object's state to get the current value for a given parame +ter. =item I<$OBJ>->command(I<command string>) =item I<$OBJ>->cmd(I<command string>) Sends a Logo command to the server. Multiple commands may be sent at +the same time by inserting a semi-colon ';' between them. The following c +ommands are available: =over 4 =item "background" or "bg" (1 argument) Sets the background color of the screen. Colors must be valid Tk colo +rs, specified either by name ("blue") or hex triplet ("#0000ff"). For exa +mple, "background orange". =item "backward" or "bk" (1 argument) Moves the turtle backwards the specified number of pixels. If the pen + is down, a line is drawn with the current color and pensize. For example +, "backward 100". [Contrast "forward"] =item "clear" or "cs" (no arguments) Clears the screen entirely. =item "color" or "co" (1 argument) Changes the current turtle color to the specified color. Both the tur +tle and any items drawn by the turtle (when the pen is down) will appear i +n this color. For example, "color white". =item "forward" or "fd" (1 argument) Moves the turtle forwards the specified number of pixels. If the pen +is down, a line is drawn with the current color and pensize. For example, "for +eward 100". [Contrast "backward"] =item "height" or "h " (1 argument) Changes the current screen height to the specified number of pixels. Note that, as this change applies to the Tk Canvas, it affects all clients which are connected to the server. For example, "height 768". [Contrast "width"] =item "hideturtle" or "ht" (no arguments) Makes the turtle invisible. Note that this is unrelated to the curren +t state of the pen; lines will still be drawn or not, depending on wheth +er the pen is up or down. [Contrast "showturtle"] =item "home" or "hm" (no arguments) Puts the turtle in its original location, at the center of the screen, + with a heading of due North (0 degrees). =item "left" or "lt" (1 argument) Rotates the turtle to the left by the specified angle, given in degree +s. Thus, an angle of 90 degrees will make an exact left turn; an angle of 180 degrees will make the turtle face the opposite direction. For exa +mple, "left 45". [Contrast "right"] =item "penup" or "pu" (no arguments) Changes the state of the turtle's "pen" so that subsequent movements o +f the turtle will no longer result in lines being drawn on the screen. As a + visual cue, the turtle will appear -without- the circle drawn around the curr +ent point. [Contrast "pendown"] =item "right" or "rt" (1 argument) Rotates the turtle to the left by the specified angle, given in degree +s. Thus, an angle of 90 degrees will make an exact right turn; an angle o +f 180 degrees will make the turtle face the opposite direction. For exa +mple, "right 135". [Contrast "left"] =item "seth" or "sh" (1 argument) Changes the turtle's heading to the specified angle. The angle given +is an absolute angle, in degrees, representing the clockwise spin relativ +e to due North. Thus, a value of 0 is due North, 90 is due East, 180 is du +e South, and 270 is due West. For example, "seth 225". =item "setx" or "sx" (1 argument) Changes the turtle's x-coordinate to the specified pixel location on t +he screen, without changing the value of the current y-coordinate. The v +alue given is an absolute location, not one related to the previous positio +n. If the pen is down, a line will be drawn from the old location to the +new one. For example, "setx 128". [Contrast "sety", "setxy" ] =item "setxy" or "xy" (2 arguments) Changes the turtle's x and y coordinates to the specified pixel locati +ons on the screen, without changing the value of the current x-coordinate. The first argument is the new x-coordinate, the second the new y-coord +inate. The position of the new point represents an absolute location, not one + related to the previous position. If the pen is down, a line will be drawn fr +om the old location to the new one. For example, "setxy 10 40". [Contrast " +setx", "sety" ] =item "sety" or "sy" (1 argument) Changes the turtle's y-coordinate to the specified pixel location on t +he screen, without changing the value of the current x-coordinate. The v +alue given is an absolute location, not one related to the previous positio +n. If the pen is down, a line will be drawn from the old location to the +new one. For example, "sety 256". [Contrast "setx", "setxy" ] =item "showturtle" or "st" (no arguments) Makes the turtle visible. Note that this is unrelated to the current +state of the pen; lines will still be drawn or not, depending on whether the + pen is up or down. [Contrast "hideturtle"] =item "pendown" or "pd" (no arguments) Changes the state of the turtle's "pen" so that subsequent movements o +f the turtle will draw the corresponding lines on the screen. As a visual c +ue, the turtle will appear with a circle drawn around the current point. [Contrast "penup"] =item "pensize" or "ps" (1 argument) Changes the width of the turtle's "pen" to the given number of pixels, + so that subsequent drawing will be done with the new line width. =item "width" or "w " (1 argument) Changes the current screen width to the specified number of pixels. Note that, as this change applies to the Tk Canvas, it affects all clients which are connected to the server. For example, "width 1024". [Contrast "height"] =item "wrap" (1 argument) Changes the screen "wrap" type on a per-client basis, to the specified argument, which must be a value of 0, 1 or 2. See L<WRAP TYPES> below for more detailed information. =item "update" or "ud" (1 argument) Changes the current update value which controls the number of millisec +onds to delay before reentering Tk's idle loop. A value of 1000 is the slowes +t; it will cause a delay of 1 second between updates. A value of 1 is the f +astest, it will make the Tk window update up to 1000 times each second. =back =back =head1 RANDOM VALUES Some of the commands can take as an argument the word "random", poss +ibly followed by more arguments which modify the random behavior. For ex +ample, the command "color random" chooses a new random color for the pen, w +hereas "seth random 80 100" sets the turtle heading to a random angle betwe +en 80 and 100 degrees. The number of arguments following "random" depend on the context: angles ........ 2 arguments (mininum angle, maximum angle) distances ..... 2 arguments (minimum distance, maximum distance) other ......... no arguments =head1 WRAP TYPES The parameter 'wrap' defines the behavior that occurs when the turtle's destination point is outside of the display window. The allowable values for wrap are: 0: Normal "no-wrap" behavior 1: Toroidal "round-world" wrap 2: Reflective wrap Consider the following diagram: +---------------o---------------+ | /| (xb0,yb0) | | <C> / | | / | | | (x2,y2) o | | [wrap = 1] | | | | | [wrap = 2] | | | (x3,y3) o @ (x0,y0) | | \ | / | | <D> \ / <A> | | \|/ | +---------------o---------------+ / (xb1,yb1) <B> / / (x1,y1) @ [wrap = 0] Point (x0,y0) represents the current location of the turtle, and (x1,y1) the destination point. Since the destination is outside of the display window, the behavior of both the turtle and the drawn line will be governed by the value of the 'wrap' parameter. Since line segment <A> is in the visible window, it will be drawn in all cases. Since line segment <B> is outside of the visible window, it will not be visible in all cases. When (wrap == 0), only line segment <A> will be visible, and the turtle, which ends up at point (x1,y1), will NOT. When (wrap == 1), the window behaves like a torus, so that line segment <B> "wraps" back into the window at the point (xb0,yb0). Thus line segments <A> and <C> are visible, and the turtle ends up at point (x2,y2). When (wrap == 2), the borders of the window are reflective, and line segment <B> "reflects" at the point (xb1,yb1). Thus line segments <A> and <D> are visible, and the turtle ends up at the point (x3,y3). =head1 EXAMPLES The following programs show some of the various ways to use the Language::Logo object. ################################# ### Randomly-colored designs ### ################################# use Language::Logo; my $lo = new Logo(title => "Logo Demonstration"); $lo->command("update 2; color random; pendown; hideturtle"); for (my $i = 1; $i < 999; $i++) { my $distance = $i / 4; $lo->command("forward $distance; right 36.5"); $lo->command("color random") if not ($i % 50); } $lo->disconnect("Type [RETURN] to finish..."); ################################################ ### Randomly placed "rings" of random widths ### ################################################ use Language::Logo; my $lo = new Logo(title => "Random rings", update => 5); $lo->cmd("wrap 1"); # Toroidal wrap while (1) { $lo->cmd("pu; sx random 1 512; sy random 1 512; pd; co random" +); $lo->cmd("pensize random 1 32"); my $dist = 5 + (rand(50)); for (my $i = 0; $i <= 360; $i += $dist) { $lo->cmd("fd $dist; rt $dist"); } } ################################### ### Fullscreen "Frenetic Lines" ### ################################### use Language::Logo; my $lo = new Logo(width => 1024, height => 768, update => 3); # Change "1" to "2" for reflection instead of torus $lo->cmd("wrap 1"); $lo->cmd("setx random 0 800"); # Choose random x-coordinate $lo->cmd("sety random 0 800"); # Choose random y-coordinate $lo->cmd("rt random 0 360"); # Make a random turn $lo->cmd("pd"); # Pen down $lo->cmd("ht"); # Hide turtle my $size = 1; # Starting pen size while (1) { if (++$size > 48) { $size = 1; # Reset the size $lo->cmd("cs"); # Clear the screen } $lo->cmd("ps $size"); # Set the pensize $lo->cmd("color random"); # Random color $lo->cmd("fd 9999"); # Move the turtle $lo->cmd("rt random 29 31"); # Turn a random angle } =head1 BUGS The following items are not yet implemented, but are intended to be addressed in a future version of the library: =over 4 =item * There is no provision for compiling "pure" Logo language code. Such capabilities as loops, conditionals, and subroutines must be handled in the calling Perl program. =item * There is no way to change the processing speed on a per-client basis. =item * There is no way to synchronize multiple clients to wait for one anothe +r. =item * There are still some commands which do not support a "random" paramete +r ("setxy" and "background", for example). =item * There is currently no analog command to "setxy" ("offxy" ?) which chan +ges the position of the turtle's location I<relative> to the current point +, as opposed to setting it absolutely. =item * There is no way to synchronize multiple clients to wait for one anothe +r. =item * It would be nice to be able to draw things other than lines; for examp +le ovals, polygons, etc. It would also be nice to be able fill these wit +h a given "fill" color. =item * There needs to be a way to save the current screen to a file (eg. as PostScript). =head1 AUTHOR John C. Norton jcnorton@charter.net Copyright (c) 2007 John C. Norton. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 VERSION Version 1.000 (January 2007) =head1 REQUIREMENTS The Tk module is required. =head1 SEE ALSO perl(1) =cut

Its documentation is in POD format; all of the basic commands are there, as well as some examples of usage.

And here are some scripts I've written to demonstrate the module:

#!/usr/bin/perl -w # # "logo.pl" -- a simple Logo interpreter use strict; use warnings; use Language::Logo; my $lo = new Logo()->interact();

#!/usr/bin/perl -w # # "spiral.pl" (a number of other programs call this) # # Draws one or more spirals using the Logo library # # 070108 by liverpole # # Strict use strict; use warnings; # Libraries use lib "."; use Language::Logo; use Data::Dumper; use File::Basename; use Getopt::Long; # Globals my $iam = basename $0; my $b_toroid = 0; my $b_reflect = 0; my $b_debug = 0; my $bg = ""; my $host = ""; my $b_hide = 0; my $color = ""; my $update = ""; my $width = ""; my $maxsize = 512; my $minsize = 8; my $minang = -1; my $incr = 2; my $startsize = 0; my $nticks = 0; my $tickcnt = 0; my $pos = 0; my $syntax = " syntax: $iam [switches] <angle> Uses Logo to create a spiral with the specified update and angle. The update specifies the update interval of the gui (iterations per second between 1 (very fast) and 1000 (very slow)). Switches: -d ............ starts the Logo server in debug mode -t ............ 'toroidal' -- sets wrap to 1 -r ............ 'reflect' -- sets wrap to 2 -h <host> ..... connects to server on given host (':' = localh +ost) -x ............ hides the turtle -a <min> ...... use a random angle from <min> to the given <an +gle> -b <color> .... specifies the Canvas background color -c <color> .... specifies the pen color -u <update> ... specifies the update speed -w <width> .... specifies the pen width -s <size> ..... specify the starting size -i <incr> ..... increment the size each time by <incr> -n <nticks> ... change the color after <nticks> 'ticks' -p <x,y> ...... make the starting position (X, Y) "; # Command-line my $result = GetOptions( "d" => \$b_debug, "x" => \$b_hide, "t" => \$b_toroid, "r" => \$b_reflect, "b=s" => \$bg, "c=s" => \$color, "h=s" => \$host, "u=s" => \$update, "w=s" => \$width, "a=s" => \$minang, "s=s" => \$startsize, "i=s" => \$incr, "n=s" => \$nticks, "p=s" => \$pos, ); $result or die $syntax; (my $angle = shift) or die $syntax; # Main program # Create Logo object my @opts = (debug => $b_debug); $bg and push @opts, bg => $bg; # Initial canvas color $host and push @opts, host => $host; # Connect to an existing server my $lo = new Logo(@opts); # Issue logo commands $update and $lo->cmd("update $update"); if ($startsize) { my $half = $startsize / 2; my $quarter = $half / 2; $lo->cmd("rt 90; bk $quarter; lt 90; bk $half"); } $width and $lo->cmd("pensize $width"); $color and $lo->cmd("color $color"); $b_hide and $lo->cmd("ht"); $b_toroid and $lo->cmd("wrap 1"); $b_reflect and $lo->cmd("wrap 2"); if ($pos) { ($pos =~ /(\d+),(\d+)/) or die "$iam: invalid position '$pos'\n"; my ($x, $y) = ($1, $2); $lo->cmd("xy $x $y"); } $lo->cmd("pendown"); # Create spiral spiral($startsize, $angle); # Disconnect from main client $host or $lo->disconnect("Type [RETURN] to disconnect ... "); # Subroutines sub spiral { my ($size, $angle) = @_; while (($incr <= 0 and $size >= $minsize) || ($incr >= 0 and $size <= $maxsize)) { $lo->cmd("forward $size"); # Move & draw turtl +e if ($minang >= 0) { $lo->cmd("rt random $minang $angle"); # Make a random tur +n } else { $lo->cmd("rt $angle"); # Turn <angle> degr +ees } # Change pen color randomly if ($nticks and ++$tickcnt >= $nticks) { $lo->cmd("color random"); $tickcnt = 0; } $size += $incr; } }

#!/usr/bin/perl -w # # "boxes.pl" -- randomly colored boxes use strict; use warnings; system("spiral.pl -t -x -u 1 -n 10 -s 100 -w 8 -p 200,300 -i -.01 -a 8 +5 95")

#!/usr/bin/perl -w # # "double.pl" -- an example of 2 simultaneous clients use strict; use warnings; # Main program if (fork) { system("flowers.pl 35.6"); } else { system("flowers.pl -h : 324.4"); }

#!/usr/bin/perl -w # # "flowers.pl" -- uses the "spiral.pl" program to # create colorful growing patterns. # # Uses Language::Logo (in conjunction with the spiral program) to crea +te # different-colored growing 'flowers'. # # 070113 by liverpole # # Strict use strict; use warnings; # Libraries use File::Basename; use Getopt::Long; # Globals my $iam = basename $0; my $host = ""; my $b_toroid = 0; my $b_reflect = 0; my $syntax = " syntax: $iam [switches] <angle> Uses Logo (in conjunction with the spiral program) to create different-colored growing 'flowers'. Try, for example, one of: $iam 33 $iam 35.9 $iam 36 $iam 38 $iam 90.1 $iam 91 $iam 100 $iam 134 $iam 300 Switches: -t ............ 'toroidal' -- sets wrap to 1 -r ............ 'reflection' -- sets wrap to 2 -h <host> ..... connects to server on given host "; # Command-line my $result = GetOptions( "h=s" => \$host, "t" => \$b_toroid, "r" => \$b_reflect, ); $result or die $syntax; (my $angle = shift) or die $syntax; my $args = "-x -c gold -u 1 -n 90 -s 50 -i .25"; $b_toroid and $args .= " -t"; $b_reflect and $args .= " -r"; $host and $args .= " -h $host"; # Main program system("spiral.pl $args $angle");

#!/usr/bin/perl -w # # "lines.pl" -- draws random colored lines using Logo, either with # a wrap of 1 (torus) or a wrap of 2 (reflection). # # 070116 by liverpole # # Strict use strict; use warnings; # Libraries use lib "."; use Language::Logo; use File::Basename; use Data::Dumper; use Getopt::Long; # User-defined my $nticks = 100; # Change color after nticks my $tickcnt = 0; # Number of ticks so far my $color = 'yellow'; # Starting pen color my $size = 2; # Pen size my $maxsize = 16; # Maximum pen size my $mindis = 5; # Minimum distance to advance my $maxdis = 50; # Maximum distance to advance my $width = 500; # Screen width my $height = 500; # Screen height my $dist = 9999; # Distance to move forward # Globals my $iam = basename $0; my $b_reflect = 0; my $syntax = " syntax: $iam [switches] <min angle> <max angle> Tests round-world scenarios with lines which continuously change a +ngles. Each time the color changes, a new random angle between <min angle +> and <max angle> is chosen, and the line is rotated by that amount. Switches: -r ............ reflect mode (wrap 2) instead of torus mode (w +rap 1) Try, for example, one of: $iam 29 31 $iam 85 95 $iam 170 190 "; # Command-line my $result = GetOptions( "r" => \$b_reflect, ); $result or die $syntax; (my $minang = shift) or die $syntax; (my $maxang = shift) or die $syntax; # Main program # Create Logo object my $lo = new Logo(width => $width, height => $height); my $wrap = $b_reflect? 2: 1; $lo->command("wrap $wrap"); $lo->command("update 5"); $lo->command("pu"); # Pen-up $lo->command("setx random 0 800"); # Choose random x-coordinate $lo->command("sety random 0 800"); # Choose random y-coordinate $lo->command("rt random 0 360"); # Make a random turn $lo->command("pendown; color $color"); # Start drawing $lo->command("ht"); # Hide turtle while (1) { if (++$size > $maxsize) { $size = 1; $lo->command("cs"); } $lo->command("ps $size"); $lo->command("color random"); $lo->command("fd $dist"); $lo->command("rt random $minang $maxang"); }


s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/

Comment on RFC: Language::Logo
Select or Download Code
Re: RFC: Language::Logo
by zentara (Archbishop) on Jan 30, 2007 at 12:50 UTC
    Big smile on my face! This is very cool and timely, considering the current big interest in remote robotics. All the examples ran well for me, and used surpising little cpu, well done. This is such a simple, yet elegant idea, that it will probably take a few days for me to digest all of it's possibilities. One of my first thoughts though, is to make a feedback channel, (thinking robotics here), so when you issue a command, the turtle responds back that it was a success, or if a failure, the coordinates where it was stopped. That way you could setup a artificial intelligence routine to map out accesible and non-accessible areas and paths around obstacles. It kind of reminds me of those floor sweeper mini-robots. :-)

    I guess a good challenge to someone, would be to write a script to completely search an area, in the least time, with the least movement. I just saw a news report where UPS drivers are now being given delivery routes, where they only make right turns, since left turns usually mean a time consuming wait at a light, or intersection. Maybe you could use this module to map out those sort of problems, given a fixed set of coordinates to visit, a set of paths ( streets), and legal street directions?

    One of the biggest early hurdles was getting past the well-known fact that you can't do Tk within a child thread

    I think the Tk canvas is an excellent widget for this, but the Gnome2::Canvas, does allow for you to access Gtk widgets from within the child threads, with it's "thread-safety" mechanism. I would suggest that, but the Gnome2::Canvas development has been frozen, and has an iffy future. There is a promising replacement though, called Papyrus which you may want to look at. It dosn't have a perl port yet, but it can't be far off. All in all though, the Tk canvas is still the best thing going out there, for simple drawing.


    I'm not really a human, but I play one on earth. Cogito ergo sum a bum
      Thanks for the feedback, zentara!

          One of my first thoughts though, is to make a feedback channel

      That's an excellent idea.

      Actually the module already does have the server respond to the client after each command.  It did occur to me previously that it might be useful to send back a better response than just "" (blank) for success, but I never implemented it.

      Let me try modifying the code to send back the client's (x, y) position (and possibly one or two other parameters); the client side can then parse the values from the response, and make them available to the calling program.

      Update:  I've made some fairly large changes to the module, such that the query command (and the alias ask) are no longer necessary.  Instead, every time command (or cmd) is called, the user is passed back a hash containing all "interesting" parameters and their values.

      I've got to first make sure that my tests still run, but after that I'll be posting the module to CPAN soon (hopefully this evening).

      Update 2:  The code is now available at CPAN.


      s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/
Re: RFC: Language::Logo
by wulvrine (Friar) on Jan 30, 2007 at 14:25 UTC
    Beautiful, simply beautiful.
    I am more impressed every revision of this I have seen. I love the multiple turtles per screen, allowing very interesting effects/wars. It is great to see someone take TK to 'the next level'. I also love that the client creates a server automagically if it doesn't exist already.
    Fine example of code.

    s&&VALKYRIE &&& print $_^q|!4 =+;' *|
Re: RFC: Language::Logo
by belg4mit (Prior) on Jan 31, 2007 at 00:06 UTC
    Have you looked into the Tk::CanvasLogo that Mr. London created in response to your presentation?

    --
    In Bob We Trust, All Others Bring Data.

      Yes, I have.

      To be very honest with you, I was somewhat amazed that he did that.

      After presenting my own idea and working code to the group (including all of the Tk drawing primitives which he then reimplemented, as well as a number which he did not), he then apparently thought it enough of a good idea to try rewriting (partially) and uploading to CPAN himself, but not good enough of an idea to mention my presentation or prior work, or the fact that he used the exact same "look and feel" of a "pen-up" turtle vs. a "pen-down" turtle.

      Additionally, he points out that "his" work allows for multiple turtles simultaneously.  In fact, this was an idea which came out of the client/server model I had already used (and presented), and was in fact originally an idea proposed to me by my colleague wulvrine.

      Now it may be that I'm just being naive to how open-source is supposed to work.  But after emailing Mr. London, and telling him that I was still planning on releasing my work to CPAN, he wrote back that it wasn't his intent to take anything away from what I had done, and offered to let me take over what he had already done.

      So the way it's been left is that I'm going to maintain the Tk::CanvasLogo project.  I still need to find out exactly what the process is for doing that.


      s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/
        Well, I think the point was that he really wanted you to inherit from Canvas. uri bitched about other aspects of the code, not inheriting bugged Greg. I was surprised at the module implementation though, as I still think that some division between Language::Logo and the visual aspect (Tk::Canvas::Logo, or what have you) be separated.

        As for taking over, the easiest is for him to give you commit bits to the project on PAUSE. You will then both have the ability to publish, though he would still be the first listed name in the module list. You could of course try to "set the record straight" in the POD with any updates.

        --
        In Bob We Trust, All Others Bring Data.

Re: RFC: Language::Logo
by Ace128 (Hermit) on Jan 31, 2007 at 01:33 UTC
Re: RFC: Language::Logo
by mreece (Friar) on Jan 31, 2007 at 05:08 UTC
    useless use of comments ;)
    # Connect to the server $self->connect_to_server(); # Return the object return $self;
    ++Logo
Re: RFC: Language::Logo
by chanio (Priest) on Jan 31, 2007 at 05:28 UTC
    Another quick response due to the impression of your amazing module and idea:

    I recall using one of the oldest versions of Logo in Apple II.

    It consisted of a very simple screen and a command line input.

    As it's main purpose was to provide the student with a way of learning through trial and error, it just accumulated commands that where interactively tried on screen. After trying a bunch of them, they where sort of committed to the turtle as a complete set of instructions and then built as a series of commands to be saved as a module or function.

    The fun was that with only trying things one was learning how to move the turtle and at the same time, learning to program in Logo.

    The scripts where very clear. With nothing else but those tested commands. Then they where compiled into one of the oldest Apple Pascal language.

    During the compilation, some output was shown but fast erased in order to bring no confusion to the student.

    Besides the graphic screen, I heard that there was actually a real turtle robot with a pencil at it's center that would move up and down as it was expected. It was connected to the apple with a serial cable. But I didn't have the luck of studying in such centers...

    Logo resulted very addictive to me at those old days. I was meant to only test the language but couldn't resist trying more and more. It was more like a game than a programming tool, although I have later heard of very interesting arquitectural designs done with Logo.

    Of course that I will try this module. In several aspects I believe that it is another masterpiece.

    The main idea of my writing is to remember you of the importance of having as interfase a clear screen with just the plain logo commands that would be tested and some kind of result. Please, find some place to subscribe to let others help you improving your module. Not in a full time, in my case, but with some little contributions that might help the final result.

    echo 'jUSt ANOther PERl HACKer' | morse -s | perl -e"while (<>){chom +p; my $out=$_; $out=~s/\s//g; $out=~tr/\-\.\,/10 /;print($out)}"| per +l -e"while (<>){chomp; my $deco=$_; $deco=~tr/01/.-/; $deco=~s/\s/\,\ +n/g; print substr($deco,0,-2),$/}" | demorse
Re: RFC: Language::Logo
by AltBlue (Chaplain) on Jan 31, 2007 at 16:43 UTC
    Great toy. Kudos ;-)

    Here's a more usable interact using Term::Readline. OFC, I named it interact2 just to avoid overriding your code ;-)

    sub interact2 { my $self = shift; eval { require Term::ReadLine }; die "This method requires Term::ReadLine.\nError was: $@\n" if $@; # used for completion my @commands = map { $_->[0] } values %{$palias}; my $term = Term::ReadLine->new('Logo'); $term->Attribs->{attempted_completion_function} = sub { my $word = shift; $term->Attribs->{completion_word} = \@commands; return $term->completion_matches( $word, $term->Attribs->{list_completion_function} ); }; $term->Attribs->{attempted_completion_over} = sub {}; while () { my $cmd = $term->readline( 'logo> ' ); last if !defined $cmd; for ($cmd) { s/^\s+//; s/\s+$//; } next if $cmd !~ /\S/; if ( $cmd eq '?' || $cmd eq 'help' ) { $self->interactive_help(); } elsif ( $cmd =~ /^(?i:q(?:uit)?|bye|exit)$/ ) { last; } else { $self->interactive_command($cmd); # adding only valid commands would be nice # - possible if "interactive_command" returns some status $term->addhistory($cmd); } } return 0; # Exit interactive mode }

    Obviously, it requires Term::ReadLine to basically work, and Term::ReadLine::Gnu to be able to use the custom completion method.

Re: RFC: Language::Logo
by eric256 (Parson) on Feb 03, 2007 at 16:07 UTC

    Hey, I love LOGO!

    Realy who doesn't? Many of us started programming in logo so it will always hold a special place for us. However I don't think this module does enough to be that logo we miss. I mean you need to supply a full set of programming options so that kids can use it and learn. Learning that I could use repeat to make a circle beat doing it by hand, and then latter learn to use 'to circle :radius' things just got better and better. I think you've made an awesome start, and the client/server idea is genius!, but I think before you go to far with it you should consider what changes to the parser need made in order to accomplish a fuller implementation of LOGO.

    /me can remember himself with a notebook full of procedures/functions to try next time he got access to the logo computer! ;)

    I was trying to add repeat when I noticed you were splitting up the commands before sending them to the server, i was wondering if it wouldn't make more sense to have all commands just sent to the server raw and have the client be just a very thin client. Off I go to see how to split on ; only outside of ....hmmm


    ___________
    Eric Hodges
      Thanks for the enthusiastic comments!

      Don't worry -- I know it needs to implement more programming options.  But I wanted to create something workable first, get feedback on that, and then go from there.

      There's a lot of of fun you can have driving it around the way it is, even if you have let Perl do the steering.  And you can even write code that looks a lot like Logo.  For instance, using the Spiral example at Wikipedia as a starting point, you could implement a reasonably similar Perl subroutine that provides the same drawn output:

      use strict; use warnings; use Language::Logo; my $l = new Logo(bg => 'white'); $l->cmd("co black; pd"); spiral(10); # # From http://en.wikipedia.org/wiki/Logo_programming_language # (Example_8) "A spiral drawn using recursion" # # to spiral :size # if :size > 30 [stop] ; a condition stop # fd :size rt 15 ; many lines of action # spiral :size *1.02 ; the tailend recursive call # end sub spiral { my $size = shift; if ($size > 30) { return } # a condition stop $l->cmd("fd $size; rt 15"); # many lines of action spiral($size * 1.02); # the tailend recursive call }

      So now that I have the basics working, I will concentrate on what needs to be done to provide more of the Logo language.

      Any constructive feedback is, of course, very welcome!


      s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/

        I had an itch and had to scratch it so I implemented brackets, a repeat command, and a rudimentary ability to define user functions. In order to do most of this I moved the command parsing code to the server itself which means user defined functions are available to any connected clients! ;)

        Drawing a circle now:

        pendown; repeat 35 [left 10; forward 10;];

        Making a circle function:

        to circle [ repeat 35 [ left 10; forward 10;]]; circle;

        I'm not sure what the best way is to get you the changes so I've attached the entire modified version.


        ___________
        Eric Hodges

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlmeditation [id://597268]
Approved by bobf
Front-paged by McDarren
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: (12)
As of 2014-08-21 16:20 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The best computer themed movie is:











    Results (136 votes), past polls