Universal Lambda Machine: Difference between revisions
m
Move Haskell before JavaScript
imported>Tromp m (stats to stderr) |
m (Move Haskell before JavaScript) |
||
| (17 intermediate revisions by 5 users not shown) | |||
Line 25:
Also, the 342 bit program
<
should produce output
<
For byte-mode, one should reproduce the
Line 33:
* https://rosettacode.org/wiki/Hilbert_curve#Binary_Lambda_Calculus
* 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}}==
Line 40 ⟶ 57:
Bit-wise (the whitespace is actually not part of the program and should be removed before feeding it into the universal machine) :
<
10100000
00010101
Line 60 ⟶ 77:
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):
<
05580
05f00
Line 76 ⟶ 93:
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">#
#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,
Line 117 ⟶ 180:
}
</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}}==
Line 193 ⟶ 314:
=={{header|Perl}}==
<syntaxhighlight
sub bit2lam {
my $bit = pop;
Line 246 ⟶ 367:
$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}}==
Line 348 ⟶ 778:
$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>
| |||