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

A Sweet Little Esolang Implementation

by corenth (Monk)
on Mar 24, 2013 at 23:23 UTC ( #1025196=CUFP: print w/ replies, xml ) Need Help??

Some time ago, I tried my hand at an Esoteric Programming Language, Iris.

To commemorate the birth of my first yungin' on the 22nd of March 2013, I've built Amelia. It's amazing what a little positive motivation can bring about. (She's already a little monkey!)

What follows is the implementation followed by a fibonacci program written in Amelia.

Implementation:
#!/usr/bin/perl #use warnings; use strict; use Data::Dumper; my $file = "sequence.ama"; my $string = get_file($file); my $still_alive = 1000; my @C = get_chromosome($string); my @R = qw//; wrapper(0,$still_alive); sub get_file{ my $infile = shift; my $string; open (my $fh, "<", $infile) or die "nopen $infile, $!"; while (<$fh>){ chomp; s/:.*//; #comments s/(\d)\s/$1,/g; #space to comma s/(\d);/$1,;/g; # forgottn comma before ; s/\s//g; #get rid of space s/,,+/,/g; #get rid of duplicate commas $string .= $_ } return $string; } sub output{ for (@R){ print "$_ "; } } sub finish{ my $message = shift; print "$message \nthe end. let's print output:\n"; output (\@R); die } sub deathcount{ $still_alive--; finish ("counted down\n") unless ($still_alive); } sub get_chromosome{ my $Genome = shift;#string my @C = map { [ map{ [ /(\d+),/g # the parens excise the commas ] } /\d+,\d+,\d+,/g ] } split /;/, $Genome; for (@C){ if ($#$_ > 1) { unless ($#$_ % 2){ splice @$_, -1, 1 } } } @C # @C[gene[codon[base,base,base]]] } sub wrapper{ my $ptr = shift; #genome pointer my $dead_count = shift; #max iterations before death my $i = $dead_count + 1; #iterator for top level call() while (1) { $ptr = call ($ptr, $i); #ptr is changed to call()'s return value if we #ever get to this point } } sub call{ my $ptr = shift; my $i = shift; my $alt_ptr = -1; for (1 .. $i){ deathcount(); #count down to process death my @g = map { [@$_] }@{$C[$ptr]}; #gene my $call = shift $g[0]; #1st base of 1st codon my $modcall = $call % 2; ($call % 2)?($alt_ptr = MOV(\@g,$ptr)):(MOD(\@g)); (return $alt_ptr) if ($alt_ptr >= 0); $ptr == $#C ? $ptr = 0 : $ptr++;#circular chromosome } return $alt_ptr; #if alt_ptr >= 0 #alt_ptr is used to reset ptr permanently. #the recursive calls to call() are unwound in favor of alt_ptr } sub MOD{ my $g = shift; #gene my ($loc,$reftype) = @{(shift @$g)}; my @ops = qw/+ - * \/ ** %/; $loc = abs($loc); $loc = $R[$loc] if ($reftype%2); $loc = 0 unless $loc; $R[$loc] = expression_processor($g,\@ops); } sub MOV{ my $g = shift; my $ptr = shift; #needed to check for infi-loop my @ops = qw/== > < >= <= != and or not xor/; my ($loc,$i) = @{(shift @$g)}; $loc = abs $loc; $loc = 0 if $loc > $#C; $i = abs $i; if (expression_processor($g, \@ops)){ (finish ("pointer collision")) if ($loc == $ptr); return $loc unless $i; return call($loc,$i); } return -1 } sub filter_v_or_o{ my ($v,$o,$total_bits,$orig) = @_; (return 0) if ($v-1 <= $o); (return 1) if ($v >= ($total_bits / 2)); return ($orig % 2) } sub expression_processor{ #build a polish notation expression from tri +plets. my $g = shift; #gene my $ops = shift; #operators my ($v,$o) = 0; #init counting vars my $total_bits = $#$g; my @expression; while (@$g){ my ($v_or_o, $data, $ref_type) = @{(shift @$g)}; $v_or_o = filter_v_or_o($v,$o,$total_bits,$v_or_o); $ref_type = ($ref_type % 3); ($data = $R[abs($data)]) if ($ref_type == 1); ($data = $R[$R[abs($data)]]) if ($ref_type == 2); $data = 0 unless $data; ($data = $ops->[$data % ($#$ops +1)]) if ($v_or_o); ($v_or_o)?($o++):($v++); unshift @expression, $data; } return solve(\@expression) } sub solve{ my $exp = shift; #print "this is the expression:"; #print Dumper $exp; #sleep 1; my $a = shift @$exp; ($a=~/\d/)? (return $a) : ($a = eval(solve($exp) . " $a " . solve($exp))); (finish("termination with n/0\n")) if ($@=~ /Illegal/); return $a; }
Fibbonacci code in Amelia:
0,0,0, :assigns a value to register 0, 0,5,0,; :the value is 5 0,3,0, : register 3 0,0,0,; : gets a 0 0,4,0, : register 4 0,1,0,; : gets a 1 0,1,0, : register 1 gets 0,1,0, : 1 0,0,1, : register[0] 0,1,0,; : - : - register[0] 1 (prefix notation) 0,2,0, : register 2 gets 0,1,0, : 1 0,1,1, : register[1] 0,1,0,; : - : - register[1] 1 (prefix notation) 0,0,1, : location referenced by register [0] 0,1,2, : value in register[2] is a reference to 0,2,2, : another register (this changes during run) 0,0,0,; : + : this produces each value in the : Fibonacci sequence 0,0,0, : add 1 to register[0] 0,0,1, 0,1,0, 0,0,0,; 1,7,0, : go to gene 7 0,25,1,; : if register[25] has a value : (other than 0) : this is gene 7 (infinite loop) : this is one way to end the program 1,3,0, :go to gene 3 1,1,0,; :if (1) :this is how we iterate ################## : this following is alternate way to terminate a program 0,0,0, : (gene 9) assign a divide by zero 0,0,0, 0,0,0, 0,3,0,; : / 0 0 (illegal devide by 0 - :ends program and outputs)
Output from Fibonacci:

26 24 23 0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181 6765 10946 17711

The first three numbers are used for flow control.

$winks = 40; $food = crow; $state{$tired}?sleep($winks):eat($food);

Comment on A Sweet Little Esolang Implementation
Select or Download Code
Re: A Sweet Little Esolang Implementation
by corenth (Monk) on Mar 31, 2013 at 04:34 UTC
    FYI: Amelia was 4469 grams/9 lb 13.5 oz!

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others rifling through the Monastery: (7)
As of 2014-11-24 07:18 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My preferred Perl binaries come from:














    Results (137 votes), past polls