Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Concatenative stack-based language with church encoded data structures in Purr.
module ConcatChurch is
import Prelude
# -- Helpers ---------------------------------------------------------
export $a get => match $a with
| $a' :: _ => $a'
end
export $a to-number => $a depth-start: 0
where
| $a depth-start: $n => match $a with
| Nil => $n
| $xs' :: Nil => $xs' depth-start: $n + 1
end
end
export $xs push: $a => $a :: $xs
# -- Booleans --------------------------------------------------------
export $xs False => [] :: $xs
export $xs True => [[]] :: $xs
# -- Numbers ---------------------------------------------------------
export $xs Zero => $xs False
export $xs One => $xs True
export $xs Two => $xs One Successor
export $xs Three => $xs Two Successor
export $xs Four => $xs Three Successor
export $xs Five => $xs Four Successor
export $xs Six => $xs Five Successor
export $xs Seven => $xs Six Successor
export $xs Eight => $xs Seven Successor
export $xs Nine => $xs Eight Successor
export $xs Successor => match $xs with
| $a :: $xs' => [$a] :: $xs'
end
export $xs Predecessor => match $xs with
| $a :: $xs' => $a :: $xs'
end
export $xs Add => match $xs with
| $a :: ($b :: $xs') => ($a ++ $b) :: $xs'
end where
| $a ++ $b => if $a === [] then $b
else ($a get) ++ ([$b] Successor get)
end
export $xs Multiply => match $xs with
| $a :: ($b :: $xs') => ($a times: $b out: $b) :: $xs'
end where
| $a times: $b out: $c =>
| $a === [] => [[]]
| $b === [] => [[]]
| $a === [[]] => $c
| otherwise => $a get
times: $b
out: [$b, $c] Add get
end
export $xs Eq => match $xs with
| $a :: ($b :: $xs') => if $a === $b then ([] True get) :: $xs'
else ([] False get) :: $xs'
end
# -- Control structures ----------------------------------------------
export $xs If => match $xs with
| $p :: ($t :: ($e :: $xs')) => if $p === [[]] then $t :: $xs' else $e :: $xs'
end
# -- Tuples ----------------------------------------------------------
export $xs Pair => match $xs with
| $a :: ($b :: $xs') => [$a, $b] :: $xs'
end
export $xs First => match $xs with
| ($a :: _) :: $xs' => $a :: $xs'
end
export $xs Second => match $xs with
| (_ :: ($a :: _)) :: $xs' => $a :: $xs'
end
# -- Stack operations ------------------------------------------------
export $xs Replicate => match $xs with
| $n :: ($a :: $xs') => ($n to-number replicate: $a) :: $xs'
end where
| $n replicate: $a => if $n === 0 then []
else $a :: ($n - 1 replicate: $a)
end
export $xs Quote => $xs Successor
export $xs Eval => match $xs with
| $a :: $xs' => $a fold: (_ interpret: _) from: $xs'
end where
| $a get! => match $a with
| $a' Just => $a'
end
| $xs interpret: $a => if $a String? then ((self at: $a) get!)($xs)
else $a :: $xs
end
export $xs Dip => match $xs with
| $a :: ($b :: $xs') => match ($a :: $xs') Eval with
| $a' :: $xs'' => $b :: ($a' :: $xs'')
end
end
export $xs Splice => match $xs with
| $a :: $xs' => $a + $xs'
end
export $xs Duplicate => match $xs with
| $a :: $xs' => $a :: ($a :: $xs')
end
export $xs Drop => match $xs with
| _ :: $xs' => $xs'
end
export $xs Swap => match $xs with
| $a :: ($b :: $xs') => $b :: ($a :: $xs')
end
end
let $xs FactInit => $xs One One Pair
let $xs FactNext => $xs Duplicate First Successor Swap Splice Multiply Swap Pair
let $xs Fact => ($xs push: `FactNext) Swap Replicate FactInit Swap Eval Second
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment