Universal Lambda Machine: Difference between revisions
m
Move Haskell before JavaScript
imported>Tromp mNo edit summary |
m (Move Haskell before JavaScript) |
||
| (31 intermediate revisions by 5 users not shown) | |||
Line 1:
{{task}}
One of the foundational mathematical constructs behind computer science is the universal machine, as a machine that can emulate the behaviour of any other machine, given a description of it. Alan Turing introduced the idea of a universal Turing machine in 1936–1937.
The lambda calculus is an even older, and in many ways simpler, model of computation. That simplicity is reflected in the Binary Lambda Calculus (BLC for short), which describes lambda terms with binary tokens 00 for lambda, 01 for application, and 1^n0 for variable n (which binds to the n'th enclosing lambda).
BLC also specifies a way to represent bits and lists as lambda terms, which provides the following I/O convention:
The lambda universal machine parses the binary encoding of a lambda term from the start of its input, applies that term to the remainder of input, and outputs the result interpreted as a list of bits or bytes.
BLC as a programming language has its own entry on Rosetta Code at https://rosettacode.org/wiki/Category:Binary_Lambda_Calculus which links to more detailed descriptions of the language.
;Task:
Simulate the universal lambda machine Or in other words, write a BLC interpreter. Support either bit-mode or byte-mode, or preferably both (with byte-mode as the default, and a -b command line flag for bit mode).
To test your universal lambda machine, you should execute the following BLC programs.
Line 17 ⟶ 25:
Also, the 342 bit program
<
should produce output
<
For byte-mode, one should reproduce the
Line 26 ⟶ 34:
* https://rosettacode.org/wiki/Execute_Brain****#Binary_Lambda_Calculus
When run on the 186-byte binary file https://www.ioccc.org/2012/tromp/tromp/symbolic.Blc followed by input 010000011100111001110100000011100111010, it should output
<pre>(\a \b a (a (a b))) (\a \b a (a b))
\a (\b \c b (b c)) ((\b \c b (b c)) ((\b \c b (b c)) a))
\a \b (\c \d c (c d)) ((\c \d c (c d)) a) ((\c \d c (c d)) ((\c \d c (c d)) a) b)
\a \b (\c (\d \e d (d e)) a ((\d \e d (d e)) a c)) ((\c \d c (c d)) ((\c \d c (c d)) a) b)
\a \b (\c \d c (c d)) a ((\c \d c (c d)) a ((\c \d c (c d)) ((\c \d c (c d)) a) b))
\a \b (\c a (a c)) ((\c \d c (c d)) a ((\c \d c (c d)) ((\c \d c (c d)) a) b))
\a \b a (a ((\c \d c (c d)) a ((\c \d c (c d)) ((\c \d c (c d)) a) b)))
\a \b a (a ((\c a (a c)) ((\c \d c (c d)) ((\c \d c (c d)) a) b)))
\a \b a (a (a (a ((\c \d c (c d)) ((\c \d c (c d)) a) b))))
\a \b a (a (a (a ((\c (\d \e d (d e)) a ((\d \e d (d e)) a c)) b))))
\a \b a (a (a (a ((\c \d c (c d)) a ((\c \d c (c d)) a b)))))
\a \b a (a (a (a ((\c a (a c)) ((\c \d c (c d)) a b)))))
\a \b a (a (a (a (a (a ((\c \d c (c d)) a b))))))
\a \b a (a (a (a (a (a ((\c a (a c)) b))))))
\a \b a (a (a (a (a (a (a (a b)))))))</pre>
=={{header|Binary Lambda Calculus}}==
The following self interpreters are taken from the IOCCC entry at https://www.ioccc.org/2012/tromp/hint.html
Bit-wise (the whitespace is actually not part of the program and should be removed before feeding it into the universal machine) :
<pre> 01010001
10100000
00010101
10000000
00011110
00010111
11100111
10000101
11001111
000000111
10000101101
1011100111110
000111110000101
11101001 11010010
11001110 00011011
00001011 11100001
11110000 11100110
11110111 11001111
01110110 00011001
00011010 00011010
</pre>
Byte-wise (showing https://www.ioccc.org/2012/tromp/uni8.Blc in hex, again with whitespace for decorational purposes only):
<pre> 19468
05580
05f00
bfe5f
85f3f
03c2d
b9fc3f8
5e9d65e5f
0decb f0fc3
9befe 185f7
0b7fb 00cf6
7bb03 91a1a
</pre>
=={{header|Bruijn}}==
We use bruijn's meta encoding and its [https://text.marvinborner.de/2023-09-03-21.html meta-circular self-interpreter]. Since results are not always streamed lazily, infinite output needs to be shortened by taking only the first n elements of the output list.
<syntaxhighlight lang="bruijn">
:import std/Combinator .
:import std/Number/Binary .
:import std/Meta M
:import std/List .
# converts string to list of bits
str→blc map (c ∘ lsb)
:test (str→blc "0010") ([[1]] : ([[1]] : ([[0]] : {}[[1]])))
# converts list of bits to string
blc→str map [0 '0' '1']
:test (blc→str ([[1]] : ([[1]] : ([[0]] : {}[[1]])))) ("0010")
# evaluates BLC string
main str→blc → M.blc→meta+rest → &M.eval → blc→str
# --- tests ---
id "0010"
# 342 bit IO example
io "010100011010000000011000010110011110000010010111110111100001010110000000011000011111000000101111110110010111111011001011110100111010111100010000001011100101010001101000000000010110000101011111101111100000010101111011111011111100001011000000101111111010110111000000111111000010110111101110011110100000010110000011011000100000101111000111001110"
# quine example
quine "000101100100011010000000000001011011110010111100111111011111011010000101100100011010000000000001011011110010111100111111011111011010"
# 100 doors example
doors "0001000100010101000110100000010110000011001110110010100011010000000000101111111000000101111101011001011001000110100001111100110100101111101111000000001011111111110110011001111111011100000000101111110000001011111010110011011100101011000000101111011001011110011110011110110100000000001011011100111011110000000001000000111001110100000000101101110110"
# sieve of Eratosthenes example
primes "00010001100110010100011010000000010110000010010001010111110111101001000110100001110011010000000000101101110011100111111101111000000001111100110111000000101100000110110"
:test (main id) (empty)
:test (main io) ("11010")
:test (main quine) (quine)
:test (take (+20) (main doors)) ("10010000100000010000")
:test (take (+20) (main primes)) ("00110101000101000101")
</syntaxhighlight>
=={{header|C}}==
<syntaxhighlight lang="c">#define M 50000
#include <stdio.h>
#include <stdlib.h>
#include <assert.h>
enum {I,O,V,A,L}; // Input Output Variable Application Lambda
// in term space T, application (f a) is A followed by length of f,
// followed by f and a. Variable (de-Bruijn) i is V followed by i.
long n=44,i,c,T[M]={L,A,8,A,2, V,0,L,L,V,
A,30,L,A,2,V,0,L,A,5,A,7,L,V,0,O,
A,14,L,A,2,V,0,L,A,5,A,2, V,0,O,O,A},b,s;
long nc = 0, nf = 0, na = 0; // number of cells, number freed, number of allocs
typedef struct _{long t,r; struct _*e,*n;} C;C*e,*f,*l,*S[M];
void x(long l,long u){for(;l<=u;T[n++]=T[l++]);}
long g(){i--||(i=b,c=getchar());return c>>i&1;}
void d(C*l){!l||--l->r||(d(l->e),d(l->n),l->n=f,nf++,f=l);}
long p(long m){if(g()){for(T[n++]=V;g();T[n]++){}n++;}else
T[m]=n++&&g()?(T[m+1]=p(++n),A):L,p(n);return n-m;}
int main(int t,char **_){char o;
b=t>1?0:7;T[43]=p(n);i=0;
for(t=b?10:26;;)switch(T[t]){
case I: g();i++;assert(n<M-99);if(~c&&b){x(0,6);for(T[n-5]=96;i;T[n++]=!g())
x(0,9);}x(c<0?7:b,9);T[n++]=!b&&!g();break;
case O: t=b+t>42?(o=2*o|t&1,28):(putchar
(b?o:t+8),fflush(stdout),b?12:28);break;
case V: l=e;for(t=T[t+1];t--;e=e->n){}
t=e->t;(e=e->e)&&e->r++;d(l);break;
case A: t+=2;
nc++;
f||(na++,f=calloc(1,sizeof(C)));
assert(f&&s<M);S[s++]=l=f;f=l->n;
l->r=1;l->t=t+T[t-1];(l->e=e)&&e->r++;break;
case L: if(!s--){fprintf(stderr,"\n%ld cells\n%ld freed\n%ld allocated\n", nc, nf, na);return 0;};S[s]->n=e;e=S[s];t++;break;
}
fprintf(stderr,"%ld cells %ld allocated\n", nf, na);
return T[t+2];
}
</syntaxhighlight>
=={{header|Haskell}}==
A bit-wise only ULM:
<syntaxhighlight lang="haskell">
import System.IO
import Data.List
import Text.Parsec
import Control.Applicative hiding ((<|>), many)
data WHNF = SYM !Char | FUN (WHNF -> WHNF)
fun :: WHNF -> WHNF -> WHNF
fun (SYM c) _ = error $ "Cannot apply symbol " ++ [c]
fun (FUN f) w = f w
expr :: Monad m => ParsecT String u m ([WHNF] -> WHNF)
expr = char '0' *> (buildLambda <$ char '0' <*> expr
<|> buildApply <$ char '1' <*> expr <*> expr)
<|> buildVar <$> pred.length <$> many (char '1') <* char '0' where
buildLambda e env = FUN $ \arg -> e (arg:env)
buildApply e1 e2 env = e1 env `fun` e2 env
buildVar n env = env !! n
buildIO prog = whnfToString . (prog [] `fun` ) . stringToWhnf where
stringToWhnf :: [Char] -> WHNF
stringToWhnf = foldr (whnfCons . bitToWhnf . fromEnum) whnfFalse where
bitToWhnf :: Integral a => a -> WHNF
bitToWhnf n = if even n then whnfTrue else whnfFalse
whnfCons :: WHNF -> WHNF -> WHNF
whnfCons fw gw = FUN $ \hw -> hw `fun` fw `fun` gw
whnfToString = map whnfToChar . whnfToList where
cons2sym :: WHNF
cons2sym = whnfConst . whnfConst $ SYM ':'
whnfToList :: WHNF -> [WHNF]
whnfToList l = case (l `fun` cons2sym) of
SYM ':' -> l `fun` whnfTrue : whnfToList (l `fun` whnfFalse)
FUN _ -> []
whnfToChar :: WHNF -> Char
whnfToChar iw = c where (SYM c) = iw `fun` SYM '0' `fun` SYM '1'
whnfConst :: WHNF -> WHNF
whnfConst = FUN . const
whnfTrue :: WHNF
whnfTrue = FUN whnfConst
whnfFalse :: WHNF
whnfFalse = whnfConst $ FUN id
main = do
hSetBuffering stdout NoBuffering
interact $ either (error . show) id . parse (buildIO <$> expr <*> getInput) ""
</syntaxhighlight>
Feel free to replace this by a solution for both bit-wise and byte-wise.
=={{header|JavaScript}}==
<syntaxhighlight lang="javascript">#!/usr/local/bin/node --stack-size=8192
let bytemode = process.argv.length <= 2;
var data;
var nchar = 0;
var nbit = 0;
var progchar;
function bit2lam(bit) {
return function(x0) { return function(x1) { return bit ? x1 : x0 } }
}
function byte2lam(bits,n) {
return n==0 ? (function(_) { return function(y) { return y } }) // nil
: (function(z) { return z (bit2lam((bits>>(n-1))&1))
(byte2lam(bits,n-1)) }) // cons bitn bits>n
}
function input(n) { // input from n'th character onward
if (n >= data.length)
return function(z) { { return function(y) { return y } } } // nil
let c = data[n];
return function(z) { return z (bytemode ? byte2lam(c,8) : bit2lam(c&1)) (input(n+1)) } // cons charn chars>n
}
function lam2bit(lambit) {
return lambit(function(_){return 0})(function(_){return 1})() // force suspension
}
function lam2byte(lambits, x) {
return lambits(function(lambit) {
return function(lamtail) {
return function(_) { return lam2byte(lamtail, 2*x + lam2bit(lambit)) }
}
})(Buffer.from([x])) // end of byte
}
function output(prog) {
return prog(function(c) { // more chars
process.stdout.write(bytemode ? lam2byte(c,0) : lam2bit(c) ? '1' : '0');
return function(tail) {
return function(_) { return output(tail) }
}
})(0) // end of output
}
function getbit() {
if (nbit==0) {
progchar = data[nchar++];
nbit = bytemode ? 8 : 1;
}
return (progchar >> --nbit) & 1;
}
function program() {
if (getbit()) { // variable
var i = 0;
while (getbit()==1) { i++ }
return function() { return arguments[i] }
} else if (getbit()) { // application
let p = program();
let q = program();
return function(...args) {
return p(...args)(function(arg) { return q(...args)(arg) }) // suspend argument
}
} else {
let p = program();
return function(...args) {
return function(arg) { return p(arg, ...args) } // extend environment with one more argument
}
}
}
process.stdin.on('readable', () => {
if ((data = process.stdin.read()) != null) {
prog = program()();
output(prog(input(nchar))) // run program with empty env on input
}
});</syntaxhighlight>
=={{header|Perl}}==
<syntaxhighlight lang="perl">#!/usr/bin/perl
sub bit2lam {
my $bit = pop;
sub { my $x0 = pop; sub { my $x1 = pop; $bit ? $x1 : $x0 } }
}
sub byte2lam {
my ($bits,$n) = @_;
$n == 0 ? sub { sub { pop } } # nil
: sub { pop->(bit2lam(vec$bits,$n-1,1))->(byte2lam($bits,$n-1)) }
}
sub input {
my $n = pop; # input from n'th character onward
if ($n >= @B) {
my $c = getc;
push @B, !defined($c) ? sub {sub { pop } } # nil
: sub { pop->($bytemode ? byte2lam($c,8) : bit2lam($c))->(input($n+1)) }
}
$B[$n];
}
sub lam2bit {
pop->(sub{0})->(sub{1})->() # force suspension
}
sub lam2byte {
my ($lambits, $x) = @_; # 2nd argument is partial byte
$lambits->(sub { my $lambit = pop; sub { my $tail = pop; sub { lam2byte($tail, 2*$x + lam2bit($lambit)) }
}})->(chr $x) # end of byte
}
sub output {
pop->(sub { my $c = pop; print($bytemode ? lam2byte($c,0) : lam2bit($c));
sub { my $tail = pop; sub { output($tail) } } })->(0) # end of output
}
sub getbit {
$n ||= ($c = getc, $bytemode ? 8 : 1);
vec $c,--$n,1;
}
sub program {
if (getbit()) { # variable
my $i;
$i++ while getbit();
sub { $_[$i] }
} elsif (getbit()) { # application
my $p=program();
my $q=program();
sub { my @env = @_; $p->(@env)->(sub { $q->(@env)->(pop) }) } # suspend argument
} else {
my $p = program();
sub { my @env = @_; sub { $p->(pop,@env) } } # extend environment with one more argument
}
}
$bytemode = !pop; # any argument sets bitmode instead
$| = 1; # non zero value sets autoflush
$prog = program()->();
output $prog->(input(0)) # run program with empty env on input</syntaxhighlight>
=={{header|Phix}}==
Translation of "how it works" and hence bitmode-only, except for leading ' '..'/' trick, and I managed to get Quine8 to work with only a minor kludge.<br>
If you think you can get blc8 to work, just be grateful that I decided at the eleventh hour and by the skin of my teeth against obfuscating this..
<syntaxhighlight lang="phix">
with javascript_semantics
constant IOP = 0, // code for gro, wr0, wr1, put
VAR = 1, // code for variable lookup
APP = 2, // code for applications
ABS = 3, // code for abstractions
ROOT = 1 // sentinel kept at stack[1]
sequence nexts, envps, refs, terms, // stack
mem // memory
integer ip, // instruction pointer
ep, // end of code pointer
frep, // freelist
contp, // continuation stack
envp // environment pointer
--constant M = 512 -- grow automatically
constant M = 50000 -- fixed limit (~safer)
-- (Programs that are left to run out of memory will tend to
-- gradually slow the machine, and sometimes even hang it.)
procedure grow_memory()
if M!=512 then crash("out of memory") end if
-- else 512->1024->2048->4096->8192, etc.
mem &= repeat(0,length(mem))
end procedure
procedure Gc(integer p)
// garbage collection (stack only, but not mem)
while p>ROOT do
refs[p] -= 1
if refs[p] then exit end if
Gc(nexts[p])
nexts[p] = frep
frep = p
p = envps[p]
end while
end procedure
procedure Var()
integer e = envp, t = envp,
x = mem[ip+1], i = 1
while i<=x and e!=ROOT do
e = nexts[e]
i += 1
end while
assert(e!=ROOT,"UNDEFINED VARIABLE %d", {x})
ip = terms[e]
envp = envps[e]
refs[envp] += 1
Gc(t)
end procedure
bool bitmode
string src, tgt
integer sdx = 0, b = 0, c
function nextbit()
if b=0 then
if sdx>=length(src) then return -1 end if
sdx += 1
c = src[sdx]
b = iff(bitmode?1:8)
end if
b -= 1
return shift_bits(c,b)&&1
end function
procedure Gro()
integer c = nextbit(), sc = ep+1
sequence g = iff(c!=-1?{ABS,APP,8,APP,2,VAR,0,ABS,ABS,VAR,even(c)}
:{ABS,ABS,VAR,0})
ep += length(g)
if ep>=length(mem) then grow_memory() end if
mem[sc..ep] = g
end procedure
string outlog = ""
integer o = 0, ob = 0
bool quine8 -- mini-kludge...
procedure Put()
integer ch = '1'-odd(ip)
ip = 3;
if not bitmode then
o = o*2+odd(ch)
ob += 1
if ob<8 then return end if
ch = o
o = 0
ob = 0
end if
if quine8 then
printf(1,"%02x",ch)
else
puts(1,ch)
end if
outlog &= ch
end procedure
procedure Abs()
// pops continuation and pushes it to environment
integer t = contp
contp = nexts[t]
nexts[t] = envp
envp = t
ip += 1
end procedure
procedure App()
// pushes continuation for argument
int x = mem[ip+1]
integer t = frep, e, term = ip+2+x
if t=0 then
nexts = append(nexts,0)
envps = append(envps,0)
refs = append(refs,0)
terms = append(terms,0)
t = length(terms)
end if
frep = nexts[t]
refs[t] = 1
terms[t] = term
if term>22 and term!=ep then
e = envp
refs[e] += 1
else
e = ROOT
end if
envps[t] = e
nexts[t] = contp
contp = t
ip += 2
end procedure
procedure Iop()
if ip>=ep then
Gro()
else
Put() // ip is an element of {6,13,20,21}
end if
Gc(envp)
envp = ROOT
end procedure
function NeedBit()
integer b = nextbit()
assert(b!=-1,"UNEXPECTED EOF")
return b
end function
function Parse()
integer t, start = ep, p, bit
bool need = false
while true do
if ep+2>=length(mem) then grow_memory() end if
bit = nextbit()
if bit==-1 then
if not need then exit end if
crash("UNFINISHED EXPRESSION");
elsif bit then
t = 0
while NeedBit() do t+=1 end while
ep += 2
mem[ep-1..ep] = {VAR,t}
exit
elsif NeedBit() then
t = ep+1
ep += 2;
mem[t..t+1] = {APP,Parse()}
need = true
else
ep += 1
mem[ep] = ABS
end if
end while
return ep-start
end function
procedure Krivine(bool soe)
ep = 25
mem[1..24] = {APP, 21, ABS, APP, 9, VAR, 0, ABS, APP, ABS, APP, 2,
VAR, IOP, ABS, APP, 4, APP, 1, VAR, IOP, IOP, 0, APP}
mem[25] = Parse()
{nexts,envps,refs,terms} = {{0},{0},{1},{0}}
{b,frep,contp,envp,ip} = {0,0,0,ROOT,1}
while true do
integer mip = mem[ip]
-- (aside: there is simply no way to exit loop from within
-- switch in JavaScript, since break is overloaded,
-- hence also banned on desktop/Phix under with js.)
if (mip=ABS and not contp)
or length(outlog)>length(tgt) then -- (soe all done)
exit
end if
switch mip do
case VAR: Var();
case APP: App();
case ABS: Abs();
case IOP: Iop();
default: crash("CORRUPT TERM");
end switch
end while
if not soe then -- (which has a forced early exit)
int rc = mem[ip+2]
assert(rc=0,"CONTINUATIONS EXHAUSTED")
end if
printf(1,"\n\n")
end procedure
constant tests = {{"Quine","000101100100011010000000000001011011110010111100111111011111011010"&
"000101100100011010000000000001011011110010111100111111011111011010",1},
{"Quine8",x"16468005bcbcfdf68016468005bcbcfdf680",1},
{"Sieve of Eratosthenes",
"00010001100110010100011010000000010110000010010001010111110111101001000110100001110"&
"011010000000000101101110011100111111101111000000001111100110111000000101100000110110",
"0011010100010100010100010000010100000100010100010000010000010100000100010100000100010000010"&
"0000001000101000101000100000000000001000100000101000000000101000001000001000100000100000101"&
"0000000001010001010000000000010000000000010001010001000001010000000001000001000001000001010"&
"0000100010100000000010000000000000100010100010000000000000100000100000000010100010000010000"&
"0001000001000001000100000100000001000100000001000000000101000000000101000001000100000100000"&
"0010001010001000000000001000000010001000000010001000001000000000001010000000000000000010000"&
"0100000000010000010000010100000100000000010000010000010100000100000100010100000000000100000"&
"0000101000100000100000101000000000001000100000100000001000000000100000001000000000100000001"&
"0000010000010001000000010000010001000000010001000000000000010000000001000000000001010000000"&
"0010100010100000000010000000000000100010100010000000000000100010100010000000000000000000100"&
"0100000001000000000100000001000100000100000100000000000001000100000100000100000001000001000"&
"00000000100010000010100."},
{"100 doors",
"00010001000101010001101000000101100000110011101100101000110100000000001011111110000001"&
"01111101011001011001000110100001111100110100101111101111000000001011111111110110011001"&
"11111101110000000010111111000000101111101011001101110010101100000010111101100101111001"&
"1110011110110100000000001011011100111011110000000001000000111001110100000000101101110110",
"10010000100000010000000010000000000100000000000010000000000000010000000000000000100000"&
"00000000000001"},
{"342",
"0101000110100000000110000101100111100000100101111101111000010101100000000110000111110"&
"0000010111111011001011111101100101111010011101011110001000000101110010101000110100000"&
"0000010110000101011111101111100000010101111011111011111100001011000000101111111010110"&
"111000000111111000010110111101110011110100000010110000011011000100000101111000111001110",
"11010"},
{"0^0",
"0001010110100000010110111011010",
"1"},
{"Hello, World!",
" Hello, world!\n",2},
}
for ti,t in tests do
printf(1,"%s:\n",{t[1]})
src = t[2]
bitmode = (src[1]&&#FE)='0'
quine8 = ti==2
if ti<=2 then
if quine8 then
for c in src do
printf(1,"%02x",c)
end for
else
printf(1,src)
end if
printf(1," (src)\n")
end if
object t3 = t[3]
if integer(t3) then t3 = src[t3..$] end if
bool soe = t3[$]='.' -- (force an early quit)
-- (no point leaving it running if you(/I) can't
-- be bothered to verify the output properly...)
if soe then t3 = t3[1..$-1] end if
tgt = t3
{sdx,b,outlog,o,ob} = {0,0,"",0,0}
mem = repeat(0,M) -- if M=512, extended as needed (and it will be)
Krivine(soe)
integer ld = length(outlog)-length(tgt)
if ld then
assert(soe and ld==1)
outlog = outlog[1..$-1]
end if
assert(outlog==tgt)
end for
</syntaxhighlight>
{{out}}
<pre>
Quine:
000101100100011010000000000001011011110010111100111111011111011010000101100100011010000000000001011011110010111100111111011111011010 (src)
000101100100011010000000000001011011110010111100111111011111011010000101100100011010000000000001011011110010111100111111011111011010
Quine8:
16468005BCBCFDF68016468005BCBCFDF680 (src)
16468005BCBCFDF68016468005BCBCFDF680
Sieve of Eratosthenes:
00110101000101000101000100000101000001000101000100000100000101000001000101000001000100000100000001000101000101000100000000000001000100000101000000000101000001000001000100000100000101000000000101000101000000000001000000000001000101000100000101000000000100000100000100000101000001000101000000000100000000000001000101000100000000000001000001000000000101000100000100000001000001000001000100000100000001000100000001000000000101000000000101000001000100000100000001000101000100000000000100000001000100000001000100000100000000000101000000000000000001000001000000000100000100000101000001000000000100000100000101000001000001000101000000000001000000000101000100000100000101000000000001000100000100000001000000000100000001000000000100000001000001000001000100000001000001000100000001000100000000000001000000000100000000000101000000000101000101000000000100000000000001000101000100000000000001000101000100000000000000000001000100000001000000000100000001000100000100000100000000000001000100000100000100000001000001000000000001000100000101000
100 doors:
1001000010000001000000001000000000010000000000001000000000000001000000000000000010000000000000000001
342:
11010
0^0:
1
Hello, World!:
Hello, world!
</pre>
=={{header|Python}}==
<syntaxhighlight lang="python">#!/usr/local/bin/python3
import os,sys
def bit2lam(bit) :
return lambda x0: lambda x1: x1 if bit else x0
def byte2lam(bits,n) :
if (n==0) :
return lambda _:lambda y: y
return lambda z: z (bit2lam((bits>>(n-1))&1)) (byte2lam(bits,n-1))
def input(n) : # input from n'th character onward
if n >= len(inp) :
c = os.read(0,1)
inp.append((lambda _: lambda y: y) if c==b''
else lambda z: z(byte2lam(c[0],8) if bytemode else bit2lam(c[0]&1))(input(n+1)))
return inp[n]
def lam2bit(lambit) :
return lambit(lambda _: 0)(lambda _: 1)(0) # force suspension
def lam2byte(lambits, x) :
return lambits(lambda lambit: lambda lamtail: lambda _: lam2byte(lamtail, 2*x+lam2bit(lambit)))(bytes([x]))
def output(prog) :
return prog(lambda c: os.write(1,lam2byte(c,0) if bytemode else (b'1' if lam2bit(c) else b'0')) and (lambda tail: lambda _ : output(tail)))(0)
def getbit() :
global nbit, progchar
if nbit==0 :
progchar = os.read(0,1)[0]
nbit = 8 if bytemode else 1
nbit -= 1
return (progchar >> nbit) & 1
def program() :
if getbit() : # variable
i = 0
while (getbit()==1) : i += 1
return lambda *args : args[i]
elif getbit() : # application
p = program()
q = program()
return lambda *args : p(*args)(lambda arg: q(*args)(arg)) # suspend argument
else :
p = program()
return lambda *args: lambda arg: p(arg, *args) # extend environment with one more argument
sys.setrecursionlimit(8192)
inp = []
nbit = progchar = 0
bytemode = len(sys.argv) <= 1
prog = program()(0)
output(prog(input(0))) # run program with empty env on input</syntaxhighlight>
=={{header|Ruby}}==
<syntaxhighlight lang="ruby">#!/usr/bin/ruby
def bit2lam(bit)
return lambda { |x0| lambda { |x1| bit==0 ? x0 : x1 } }
end
def byte2lam(bits,n)
return n==0 ? lambda { |_| lambda { |y| y } }
: lambda { |z| z.call(bit2lam((bits>>(n-1))&1)).call(byte2lam(bits,n-1)) }
end
def input(n) # input from n'th character onward
if n >= $inp.length()
c = STDIN.getbyte
$inp.append(c==nil ? (lambda { |_| lambda { |y| y } })
: lambda { |z| z.call($bytemode ? byte2lam(c,8) : bit2lam(c&1)).call(input(n+1)) } )
end
return $inp[n]
end
def lam2bit(lambit)
return lambit.call(lambda { |_| 0 }).call(lambda { |_| 1 }).call(0) # force suspension
end
def lam2byte(lambits, x)
return lambits.call(lambda { |lambit| lambda { |lamtail| lambda { |_| lam2byte(lamtail, 2*x+lam2bit(lambit)) } } }).call(x)
end
def output(prog)
return prog.call(lambda { |c| putc($bytemode ? lam2byte(c,0) : (lam2bit(c)==0 ? '0' : '1')) and (lambda { |tail| lambda { |_| output(tail) } }) }).call(0)
end
def getbit()
if ($nbit==0)
$progchar = STDIN.getbyte
$nbit = $bytemode ? 8 : 1
end
return ($progchar >> $nbit -= 1) & 1
end
def program()
if getbit()==1 # variable
i = 0
while (getbit()==1) do i += 1 end
return lambda { |*args| args[i] }
elsif getbit()==1 # application
p = program()
q = program()
return lambda { |*args| p.call(*args).call(lambda { |arg| q.call(*args).call(arg) }) } # suspend argument
else
p = program()
return lambda { |*args| lambda { |arg| p.call(arg, *args) } } # extend environment with one more argument
end
end
$inp = []
$nbit = $progchar = 0
$bytemode = ARGV.length <= 0
$prog = program().call(0)
output($prog.call(input(0))) # run program with empty env on input</syntaxhighlight>
=={{header|Wren}}==
{{trans|Ruby}}
Input is assumed to be terminated by pressing return.
<syntaxhighlight lang="wren">import "os" for Process
import "io" for Stdin
var inp = []
var progchar = 0
var nbit = 0
var bytemode = Process.arguments.count == 0
var bit2lam = Fn.new { |bit| Fn.new { |x0| Fn.new { |x1| bit == 0 ? x0 : x1 } } }
var byte2lam // recursive
byte2lam = Fn.new { |bits, n|
return n == 0 ?
Fn.new { Fn.new { |y| y } } :
Fn.new { |z| z.call(bit2lam.call(bits>>(n-1) & 1)).call(byte2lam.call(bits, n-1)) }
}
// input from 'n'th character onward
var input // recursive
input = Fn.new { |n|
if (n >= inp.count) {
var c = Stdin.readByte()
inp.add(c == 10 ?
Fn.new { Fn.new { |y| y } } :
Fn.new { |z| z.call(bytemode ?
byte2lam.call(c, 8) : bit2lam.call(c&1)).call(input.call(n+1)) }
)
}
return inp[n]
}
// force suspension
var lam2bit = Fn.new { |lambit| lambit.call(Fn.new { 0 }).call(Fn.new { 1 }).call(0) }
var lam2byte // recursive
lam2byte = Fn.new { |lambits, x|
return lambits.call(
Fn.new { |lambit| Fn.new { |lamtail| Fn.new { lam2byte.call(lamtail, 2*x+lam2bit.call(lambit)) } } }).call(x)
}
var output // recursive
output = Fn.new { |prog|
return prog.call(Fn.new { |c|
System.write(bytemode ? String.fromByte(lam2byte.call(c, 0)) : (lam2bit.call(c) == 0 ? "0" : "1"))
return Fn.new { |tail| Fn.new { output.call(tail) } }
}).call(0)
}
var getbit = Fn.new {
if (nbit == 0) {
progchar = Stdin.readByte()
nbit = bytemode ? 8 : 1
}
nbit = nbit - 1
return (progchar >> nbit) & 1
}
var program // recursive
program = Fn.new {
if (getbit.call() != 0) { // variable
var i = 0
while (getbit.call() == 1) i = i + 1
return Fn.new { |args| args[i] }
} else if (getbit.call() != 0) { // application
var p = program.call()
var q = program.call()
// suspend argument
return Fn.new { |args|
return p.call(args).call(Fn.new { |arg| q.call(args).call(arg) })
}
} else {
// extend environment with one more argument
var p = program.call()
return Fn.new { |args| Fn.new { |arg| p.call([arg] + args) } }
}
}
System.print("Input:")
var prog = program.call().call([0])
System.print("\nOutput:")
// run program with empty environment on input
output.call(prog.call(input.call(0)))
System.print()</syntaxhighlight>
{{out}}
342 bit example:
<pre>
Input:
010100011010000000011000010110011110000010010111110111100001010110000000011000011111000000101111110110010111111011001011110100111010111100010000001011100101010001101000000000010110000101011111101111100000010101111011111011111100001011000000101111111010110111000000111111000010110111101110011110100000010110000011011000100000101111000111001110
Output:
11010
</pre>
Quine example:
<pre>
Input:
000101100100011010000000000001011011110010111100111111011111011010000101100100011010000000000001011011110010111100111111011111011010
Output:
000101100100011010000000000001011011110010111100111111011111011010000101100100011010000000000001011011110010111100111111011111011010
</pre>
100 doors example:
<pre>
Input:
0001000100010101000110100000010110000011001110110010100011010000000000101111111000000101111101011001011001000110100001111100110100101111101111000000001011111111110110011001111111011100000000101111110000001011111010110011011100101011000000101111011001011110011110011110110100000000001011011100111011110000000001000000111001110100000000101101110110
Output:
1001000010000001000000001000000000010000000000001000000000000001000000000000000010000000000000000001
</pre>
Sieve of Eratosthenes example (output manually terminated after first 1024 bits printed):
<pre>
Input:
00010001100110010100011010000000010110000010010001010111110111101001000110100001110011010000000000101101110011100111111101111000000001111100110111000000101100000110110
Output:
0011010100010100010100010000010100000100010100010000010000010100000100010100000100010000010000000100010100010100010000000000000100010000010100000000010100000100000100010000010000010100000000010100010100000000000100000000000100010100010000010100000000010000010000010000010100000100010100000000010000000000000100010100010000000000000100000100000000010100010000010000000100000100000100010000010000000100010000000100000000010100000000010100000100010000010000000100010100010000000000010000000100010000000100010000010000000000010100000000000000000100000100000000010000010000010100000100000000010000010000010100000100000100010100000000000100000000010100010000010000010100000000000100010000010000000100000000010000000100000000010000000100000100000100010000000100000100010000000100010000000000000100000000010000000000010100000000010100010100000000010000000000000100010100010000000000000100010100010000000000000000000100010000000100000000010000000100010000010000010000000000000100010000010000010000000100000100000000000100010000010100^C
</pre>
| |||