fun/forth.bruijn

# MIT License, Copyright (c) 2025 Marvin Borner
# mini forth/postscript-like stack DSL

:import std/Tuples .
:import std/Combinator .
:import std/Number/Unary N
:import std/Logic/Binary L

# ============ #
# INSTRUCTIONS #
# ============ #

# ( a -- a )
id [1 0]

:test ([(`1 : `2 : `3) id]) (`1 : `2 : `3)

# ( a -- a a )
dup [1 0 0]

:test ([(`1 : `2 : `3) dup]) (`1 : `1 : `2 : `3)

# ( a -- )
drop [1]

:test ([(`1 : `2 : `3) drop]) (`2 : `3)

# ( a b -- b a )
swap [[2 0 1]]

:test ([(`1 : `2 : `3) swap]) (`2 : `1 : `3)

# ( a b -- a b a )
over [[2 1 0 1]]

:test ([(`1 : `2 : `3) over]) (`1 : `2 : `1 : `3)

# ( a b c -- b c a )
rot [[[3 1 0 2]]]

:test ([(`1 : `2 : `3) rot]) (`2 : `3 : `1)

# ( b (t) (f) -- t/f )
ifelse [[[0 1 2 3]]]

:test ([((`0 :) : (`1 :) : [[0]]) ifelse]) (`0 :)
:test ([((`0 :) : (`1 :) : [[1]]) ifelse]) (`1 :)

# ( a b (t) -- a t? )
if [[[1 (2 3 0) (3 0)]]]

:test ([((`1 :) : [[0]] : `2) if]) (`2 :)
:test ([((`1 :) : [[1]] : `2) if]) (`1 : `2)

# ( (a*) -- a* )
in [0 1]

:test ([((`0 : `1) :) in]) (`0 : `1)
:test ([((`0 : `1) : `2) in]) (`0 : `1 : `2)

# instructions must be values (abstractions), therefore η-expanded
# (see encode-recursively)

add [1 ∘∘ N.add 0]

sub [1 ∘∘ \N.sub 0]

mul [1 ∘∘ N.mul 0]

div [1 ∘∘ N.div 0]

eq? [1 ∘∘ N.eq? 0]

and? [1 ∘∘ L.and? 0]

or? [1 ∘∘ L.or? 0]

not! [1 ∘ L.not! 0]

app1 [2 ∘ 0]

# ======== #
# LANGUAGE #
# ======== #

:import std/Meta M

# inserts starting index and abstraction
# (programs must start with a value)
insert-start (y [M.idx : case-app : M.abs]) → M.abs
	case-app [[(M.app? 1) rec end]]
		rec M.app (2 1) 0
		end M.app (M.app `0 1) 0

:test (insert-start `(`0 `1 `2)) (`[0 `0 `1 `2])

# meta-church

# maps indices to Church numbers (syntactic sugar)
map-indices M.map (y [M.idx : case-app : M.abs])
	case-app [[M.app (2 1) (0 case-idx M.app M.abs)]]
		case-idx [M.app `0 (M.abs (M.abs (0 (M.app `1) `0)))]

:test (map-indices `[0 1 2 3]) (`[0 (0 (+1u)) (0 (+2u)) (0 (+3u))])

# inserts nested abstractions to bind free variables in instructions
insert-abstractions M.map (y [M.idx : case-app : M.abs])
	case-app [M.app (M.abs (1 0))]

:test (insert-abstractions `[0 (0 `0) (0 `1) (0 `2)]) (`[[[[0] (0 `0)] (0 `1)] (0 `2)])
:test (M.!(insert-abstractions `[0 (0 `0) (0 `1) (0 `2)])) (`2 : `1 : `0)

# calls the encode function on every application argument and wraps it
encode-recursively [y [M.idx : case-app : M.abs]]
	case-app [[M.app (2 1) (M.app? 0 (M.app `0 (3 0)) 0)]]

encode y [(encode-recursively 0) → insert-start → map-indices → insert-abstractions]

run encode → M.eval

:test (run `(1 2 3)) ((+3u) : (+2u) : (+1u))
:test (run `(1 (2 3) 4)) ((+4u) : ((+3u) : (+2u)) : (+1u))

# ======== #
# EXAMPLES #
# ======== #

:test (run `(1 2 3 dup dup drop)) ((+3u) : (+3u) : (+2u) : (+1u))
:test (run `(2 dup add)) ((+4u) :)
:test (run `(9 2 dup add sub dup mul)) ((+25u) :)

:test (run `(1 (2 3) in add 4)) ((+4u) : (+5u) : (+1u))
:test (run `(1 (2 3) in 4)) ((+4u) : (+3u) : (+2u) : (+1u))
:test (run `(1 (2 3 4) in 5)) ((+5u) : (+4u) : (+3u) : (+2u) : (+1u))
:test (run `(1 (2 (3 4) in add add) in add)) ((+10u) :)

# TODO: somehow doesn't terminate?
fib (y [[`(arg dup dup 1 eq? swap 0 eq? or? not! (dup 1 sub fib in swap 2 sub fib in add) if)]]) → run
	arg [1 ,0 0]
	fib [app1 ,1 0]

fac (y [[`(arg dup dup 1 eq? swap 0 eq? or? not! (dup 1 sub fac mul) if)]]) → run
	arg [1 ,0 0]
	fac [app1 ,1 0]

main [[0]]