Skip to content

Instantly share code, notes, and snippets.

@int-e int-e/List.hs
Last active Aug 16, 2019

Embed
What would you like to do?
Wagon
-- Wagon implementation.
--
-- Wagon is a second-order concatenative language by Chris Pressey.
-- See https://esolangs.org/wiki/Wagon for further information.
--
-- Author: Bertram Felgenhauer <int-e@gmx.de>
module List where
import Data.Char
import Debug.Trace
------------------------------------------------------------------------------
-- Running Wagon programs.
type Elem = Integer
type Stack = [Elem]
type Op = [Elem] -> [Elem]
parseOp :: Char -> Op -> Op
parseOp c = case c of
'i' -> after opI
'I' -> before opI
's' -> after opS
'S' -> before opS
'd' -> after opD
'D' -> before opD
'p' -> after opP
'P' -> before opP
'r' -> after opR
'R' -> before opR
't' -> after opT
'T' -> before opT
'@' -> while
_ | isSpace c -> id
where
opI, opS, opD, opR, opT :: Op
-- 'i'/'I': push 1
opI ss = 1 : ss
-- 's'/'S': subtract
opS (a : b : ss) = b-a : ss
-- 'p'/'P': pop
opP (_ : ss) = ss
-- 'd'/'D': dup
opD (a : ss) = a : a : ss
-- 'r'/'R': rotate bottom of stack
opR (n : ss)
| 0 <= n && n <= 1, n' <- fromInteger n, length ss >= n'
= take n' ss ++ reverse (drop n' ss)
-- 't'/'T': print current stack (extension for debugging)
opT ss = traceShow ss ss
after, before :: Op -> Op -> Op
after = (.)
before = flip (.)
-- '@': while loop
while :: Op -> Op
while o ss
| null ss || head ss == 0 = ss
| otherwise = while o (o ss)
parse :: String -> Op
parse = foldl (flip parseOp) id
run :: Op -> Stack
run = ($ [])
exec :: String -> Stack
exec = run . parse
-- Wagon implementation, take 2.
--
-- Wagon is a second-order concatenative language by Chris Pressey.
-- See https://esolangs.org/wiki/Wagon for further information.
--
-- Author: Bertram Felgenhauer <int-e@gmx.de>
module Ring where
import qualified Data.Sequence as S
import Data.Sequence (ViewL ((:<)), ViewR ((:>)), (<|), (|>))
import Data.Monoid
import Data.Char
import Debug.Trace
------------------------------------------------------------------------------
-- Running Wagon programs.
-- The program state is a stack of integers which can also be reversed;
-- it acts more like a ring structure. We model the ring as a sequence
-- that is either viewed normally (Fwd) or backwards (Bwd).
type Elem = Integer
data Ring = Fwd (S.Seq Elem) | Bwd (S.Seq Elem)
-- the empty stack/ring
empty :: Ring
empty = Fwd S.empty
-- push an element on the stack = insert an element into the ring
push :: Integer -> Ring -> Ring
push i (Fwd s) = Fwd (i <| s)
push i (Bwd s) = Bwd (s |> i)
-- pop an element on the stack = delete current element of the ring
pop :: Ring -> (Integer, Ring)
pop (Fwd s) | i :< s' <- S.viewl s = (i, Fwd s')
pop (Bwd s) | s' :> i <- S.viewr s = (i, Bwd s')
-- reverse the stack = reverse the ring
rev :: Ring -> Ring
rev (Fwd s) = Bwd s
rev (Bwd s) = Fwd s
-- check whether stack is empty
nul :: Ring -> Bool
nul (Fwd s) = S.null s
nul (Bwd s) = S.null s
-- convert ring to list
toList :: Ring -> [Elem]
toList (Fwd s) = foldr (:) [] s
toList (Bwd s) = foldl (flip (:)) [] s
-- basic operations
type Op = Ring -> Ring
-- 'i'/'I': push 1
opI :: Op
opI s = push 1 s
-- 's'/'S': subtract
opS :: Op
opS s | (a, s1) <- pop s, (b, s2) <- pop s1 = push (b - a) s2
-- 'p'/'P': pop
opP :: Op
opP s | (_, s') <- pop s = s'
-- 'd'/'D': dup
opD :: Op
opD s | (a, _) <- pop s = push a s
-- 'r'/'R': reverse
opR :: Op
opR s | (a, s1) <- pop s = case a of
0 -> rev s1
1 | (b, s2) <- pop s1 -> push b (rev s2)
-- 't'/'T': trace
opT :: Op
opT s = traceShow (toList s) s
-- parse a single operation
parseOp :: Char -> Op -> Op
parseOp c = case c of
'i' -> after opI
'I' -> before opI
's' -> after opS
'S' -> before opS
'd' -> after opD
'D' -> before opD
'p' -> after opP
'P' -> before opP
'r' -> after opR
'R' -> before opR
't' -> after opT
'T' -> before opT
'@' -> while
_ | isSpace c -> id
where
after, before :: Op -> Op -> Op
after = (.)
before = flip (.)
-- '@': while loop
while :: Op -> Op
while o s
| nul s = s
| (0, _) <- pop s = s
| otherwise = while o (o s)
-- parse program
parse :: String -> Op
parse = foldl (flip parseOp) id
-- run program
run :: Op -> [Elem]
run p = toList $ p empty
exec :: String -> [Elem]
exec = run . parse
-- Compiling tag systems to Wagon.
--
-- cf.
-- https://en.wikipedia.org/wiki/Tag_system
-- https://esolangs.org/wiki/Tag_system
module Tag where
import Data.Char
import Data.List
import qualified Ring as R
import qualified List as L
------------------------------------------------------------------------------
-- Wagon building blocks.
-- literals
num :: Int -> String
num i
| i <= 1 = "i" ++ concat (replicate (1-i) "is")
| otherwise = "i" ++ num (1-i) ++ "s"
-- whole stack rotations
rotl = num 1 ++ "r" ++ num 0 ++ "r"
rotr = num 0 ++ "r" ++ num 1 ++ "r"
rot n
| n < 0 = [1.. -n] >> rotl
| otherwise = [1..n] >> rotr
-- basic arithmetic
-- subtraction
sub :: String
sub = "s"
-- flipped subtraction
sub' :: String
sub' = concat [ -- a b xs
rotl, -- b xs a
num 1, "r", -- b a xs'
sub, -- a-b xs'
num 1, "r", -- a-b xs
""]
neg :: String
neg = num 0 ++ sub'
suc :: String
suc = num (-1) ++ "s"
pre :: String
pre = num 1 ++ "s"
add :: String
add = neg ++ "s"
-- data movement
-- swap top elements of stack
swap = concat [ -- a b xs
"d", rotl, -- a b xs a
sub', -- a-b xs a
"d", rotr, -- a a-b a-b xs
sub', -- b a-b xs
"d", rotl, -- b a-b xs b
neg, sub, -- a xs b
rotr, -- b a xs
""]
-- get element from stack (0 = top)
get 0 = "d"
get n = rotl ++ get (n-1) ++ rotr ++ swap
-- put element onto stack (0 = top)
put 0 = rotl ++ "p" ++ rotr
put n = swap ++ rotl ++ put (n-1) ++ rotr
-- reverse top n elements of the stack
rev n
| n <= 1 = ""
| otherwise = concat [
concat (replicate (n-1) (swap ++ rotl)),
rot (n-1),
rev (n-1),
""]
-- basic logic
-- logical not
lnot :: String
lnot = num 1 ++ sub'
-- logical p-and-not-q
landn = concat [
num 1, num 0, rotl, rotl, -- 0 ? xs 0 1 | 1 ? xs 0 1
"r", -- 1 0 xs' ? | ? 1 0 xs'
"p", -- 0 xs' ? | 1 0 xs'
"r", -- ? xs' | 0 xs'
""]
-- logical and
land = lnot ++ landn
-- logical or
lor = rotl ++ lnot ++ rotr ++ landn ++ lnot
-- initialize a non-empty stack for testing
ini :: String
ini = num 0 ++ ([1..9] >> ('d' : suc)) ++ num 0 ++ "r"
{-
tests so far:
> run $ ini
[0,1,2,3,4,5,6,7,8,9]
> run $ ini ++ get 3 ++ get 6 ++ put 4 ++ put 5
[0,1,2,5,4,3,6,7,8,9]
-}
-- `fromTag m h rs ini` translates an `m`-tag system with halting symbol
-- `h` and rules `rs`, and encodes the initial string `ini` as well.
fromTag :: Eq a => Int -> a -> [(a,[a])] -> [a] -> String
fromTag m h rs ini = concat [
"p@p", -- truncate to actual rhs; comes after `applyRules`
pre applyRules, -- see below
pre "t", -- trace
num 0, "r", -- reverse
replicate (l*m) 'p', -- drop first `m` symbols
ttest, pre tclean, -- loop test (at end of loop) and cleanup (at start)
"@",
pre ttest, tclean, -- initial test, final cleanup
pre $ reverse (ini >>= enc) >>= num, -- initialization
""]
where
-- collect symbols
syms = h : map fst rs
-- number of symbols
l = length syms
-- width == maximum rhs length
w = maximum $ 0 : map (length . snd) rs
-- index of symbol
idx c | Just i <- elemIndex c syms = i
-- encoding of symbol (0111, 1011, 1101, 1110 if there are 4 symbols)
enc c | i <- idx c = replicate i 1 ++ [0] ++ replicate (l-i-1) 1
-- termination test
-- there are two reasons for termination:
-- * the string becomes shorter than `m` symbols, or
-- * the next symbol is the halting symbol
ttest = concat [
-- append a bunch of zeros
num 0, "r", num 0, replicate (l*(m-1)+2) 'd', "r",
-- get first bit of first symbol
"d",
-- now fetch the first two bits of the m-th symbol;
-- this results in 0 if there is no such symbol.
get (l*(m-1)+1), get (l*(m-1)+3), lor,
-- combine
land,
""]
-- cleanup after termination test
tclean = concat [
-- drop test bit and zeros at end
"p", num 0, "r", replicate (l*(m-1)+1) 'p', "r",
""]
-- apply the tag rules
applyRules = concat [
-- push a bunch of ones; we will put the rhs here
replicate nl 'd',
concat [
-- for each rule, test whether the symbol matches
get (nl + i) ++ lnot ++ concat [
-- if so, clear the corresponding bits for the rhs
adjust (j*l + idx c)
| (c, j) <- zip r [0..]
] ++
-- mark the end of the rhs
adjust (length r * l) ++ "p"
| ((_, r), i) <- zip rs [1..]
],
-- reverse, and then rotate so that the new string is in front again
num 0, "r", rot nl,
-- next, we will clear leading 1s and a zero marker using "p@p"
""]
where
adjust i = "d" ++ get (2+i) ++ sub' ++ put (i+1)
nl = w*l + 1
-- change a loop-free code block from append ('after') to
-- prepend ('before') semantics
pre = reverse . map toUpper
{-
Example. (cf. Wikipedia)
a -> bc
b -> a
c -> aaa
The symbols are encoded as follows.
H = 0111 (halting symbol, unused in this example)
a = 1011
b = 1101
c = 1110
-}
example :: Int -> String
example l = fromTag 2 'H' rs (replicate l 'a')
where
rs = [('a', "bc"), ('b', "a"), ('c', "aaa")]
{-
test:
> R.exec $ example 3
[1,0,1,1, 1,0,1,1, 1,0,1,1]
[1,0,1,1, 1,1,0,1, 1,1,1,0]
[1,1,1,0, 1,1,0,1, 1,1,1,0]
[1,1,1,0, 1,0,1,1, 1,0,1,1, 1,0,1,1]
[1,0,1,1, 1,0,1,1, 1,0,1,1, 1,0,1,1, 1,0,1,1]
[1,0,1,1, 1,0,1,1, 1,0,1,1, 1,1,0,1, 1,1,1,0]
[1,0,1,1, 1,1,0,1, 1,1,1,0, 1,1,0,1, 1,1,1,0]
[1,1,1,0, 1,1,0,1, 1,1,1,0, 1,1,0,1, 1,1,1,0]
[1,1,1,0, 1,1,0,1, 1,1,1,0, 1,0,1,1, 1,0,1,1, 1,0,1,1]
[1,1,1,0, 1,0,1,1, 1,0,1,1, 1,0,1,1, 1,0,1,1, 1,0,1,1, 1,0,1,1]
[1,0,1,1, 1,0,1,1, 1,0,1,1, 1,0,1,1, 1,0,1,1, 1,0,1,1, 1,0,1,1, 1,0,1,1]
[1,0,1,1, 1,0,1,1, 1,0,1,1, 1,0,1,1, 1,0,1,1, 1,0,1,1, 1,1,0,1, 1,1,1,0]
[1,0,1,1, 1,0,1,1, 1,0,1,1, 1,0,1,1, 1,1,0,1, 1,1,1,0, 1,1,0,1, 1,1,1,0]
[1,0,1,1, 1,0,1,1, 1,1,0,1, 1,1,1,0, 1,1,0,1, 1,1,1,0, 1,1,0,1, 1,1,1,0]
[1,1,0,1, 1,1,1,0, 1,1,0,1, 1,1,1,0, 1,1,0,1, 1,1,1,0, 1,1,0,1, 1,1,1,0]
[1,1,0,1, 1,1,1,0, 1,1,0,1, 1,1,1,0, 1,1,0,1, 1,1,1,0, 1,0,1,1]
[1,1,0,1, 1,1,1,0, 1,1,0,1, 1,1,1,0, 1,0,1,1, 1,0,1,1]
[1,1,0,1, 1,1,1,0, 1,0,1,1, 1,0,1,1, 1,0,1,1]
[1,0,1,1, 1,0,1,1, 1,0,1,1, 1,0,1,1]
[1,0,1,1, 1,0,1,1, 1,1,0,1, 1,1,1,0]
[1,1,0,1, 1,1,1,0, 1,1,0,1, 1,1,1,0]
[1,1,0,1, 1,1,1,0, 1,0,1,1]
[1,0,1,1, 1,0,1,1]
[1,1,0,1, 1,1,1,0]
[1,0,1,1]
corresponding to
aaa -- 3
abc
cbc
caaa
aaaaa -- 5
aaabc
abcbc
cbcbc
cbcaaa
caaaaaa
aaaaaaaa -- 8
aaaaaabc
aaaabcbc
aabcbcbc
bcbcbcbc
bcbcbca
bcbcaa
bcaaa
aaaa -- 4
aabc
bcbc
bca
aa -- 2
bc
a -- 1
-}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.