★ /prog/ Challenge Vol. 5 ★

The challenge suggestion thread was too busy going nowhere, and I feel like writing some code, so here is a /prog/ challenge.

THE CHALLENGE:
Design a ^_toy programming language. You may implement either a compiler or interpreter, and you may write the implementation in any language of your choosing.

Post the source code to your implementation as well as programs in your language to accomplish ^{at least} two of the following tasks, plus one ``wild card'' program not listed here.

    • Factorial calculator
    • Fibonacci sequence generator
    • Prime number sieve (e.g. Eratosthenes, Atkin, etc.)
    • fgrep (output lines of input containing a given string)
    • Caesar cipher
    • Simple interactive calculator
    • Tic-tac-toe (AI not required)
    • The game of Nim (http://en.wikipedia.org/wiki/Nim)

Entries must be submitted prior to 2010-06-21 00:00, which gives one full week and two weekends. Judgment will be in three categories: presentation and cleverness of designed language, clarity of implementation, and overall usefulness/entertainment/trolling value of the ``wild card'' program.

Winner will receive ten Susscoins, to be transferred via /prog/mail.

here's this:
#!/usr/bin/perl

# stack.pl - an interpreter for a very simple stack-based language.
#
# fibonacci sequence generator:
# echo 'swap dup . over +' | perl stack.pl 0 1
#
# factorial calculator:
# echo '1 + dup rot dup . * swap' | perl stack.pl 1 1

use strict;
use feature qw(say switch);

local $/;
my @stack = @ARGV;
my @words = split /\s+/, <STDIN>;

do
{ for(@words)
  { given($_)
    { when(/^(?:\d*\.)?\d+$/) { push @stack, $_; }
      when('.') { say pop @stack; }
      when('dup') { push @stack, $stack[-1]; }
      when('swap') { @stack[-1, -2] = @stack[-2, -1]; }
      when('drop') { pop @stack; }
      when('over') { push @stack, $stack[-2]; }
      when('rot') { @stack[-1,-2,-3] = @stack[-3, -1, -2]; }
      when('+') { push @stack, (pop @stack) + (pop @stack); }
      when('-') { my($x, $y) = ((pop @stack), pop @stack);
                  push @stack, $y - $x; }
      when('*') { push @stack, (pop @stack) * (pop @stack); }
      when('/') { my($x, $y) = ((pop @stack), pop @stack);
                  push @stack, $y / $x; }
      when('%') { my($x, $y) = ((pop @stack), pop @stack);
                  push @stack, $y % $x; }
      when('^') { my($x, $y) = ((pop @stack), pop @stack);
                  push @stack, $y ** $x; }
      default { die "unrecognized word: $_"; }}}} while(@stack)

and then the ``wild card'' program: dup rot + 2 % rot rot ^ ^

which can be used like this:
#!/usr/bin/perl

use feature qw(say switch);

my $pattern = shift;

while(1)
{ my $newpattern = '';
  say $pattern;
  $pattern = '00' . $pattern . '00';
  for(0..(length $pattern) - 3)
  { my @part = split //, substr $pattern, $_, 3;
    $newpattern .= (exec_stack('dup rot + 2 % rot rot ^ ^ .', @part))[0]; }
  $pattern = $newpattern; }

sub exec_stack($@)
{ my @words = split /\s+/, shift;
  my @stack = @_;
  my @output = ();
  do
  { for(@words)
    { given($_)
      { when(/^(?:\d*\.)?\d+$/) { push @stack, $_; }
        when('.') { push @output, pop @stack; }
        when('dup') { push @stack, $stack[-1]; }
        when('swap') { @stack[-1, -2] = @stack[-2, -1]; }
        when('drop') { pop @stack; }
        when('over') { push @stack, $stack[-2]; }
        when('rot') { @stack[-1,-2,-3] = @stack[-3, -1, -2]; }
        when('+') { push @stack, (pop @stack) + (pop @stack); }
        when('-') { my($x, $y) = ((pop @stack), pop @stack);
                    push @stack, $y - $x; }
        when('*') { push @stack, (pop @stack) * (pop @stack); }
        when('/') { my($x, $y) = ((pop @stack), pop @stack);
                    push @stack, $y / $x; }
        when('%') { my($x, $y) = ((pop @stack), pop @stack);
                    push @stack, $y % $x; }
        when('^') { my($x, $y) = ((pop @stack), pop @stack);
                    push @stack, $y ** $x; }
        default { die "unrecognized word: $_"; }}}} while(@stack);
  return @output; }