If you've used TinyAPL (which you probably haven't) you might've noticed the lack of a pretty important feature that's present in most modern APLs: trains. In this post I finally add them, with a TinyAPL spin of course.

Code is available, as usual, in a GitHub repository.

## Depth

First, a simple primitive, which returns the "level of nesting" of an array: `0`

for scalars, `1`

for simple arrays, one more than the maximum depth of the elements for nested arrays:

```
depth :: MonadError Error m => Array -> m Natural
depth (Array [] [Box xs]) = (1+) <$> depth xs
depth (Array [] _) = pure 0
depth (Array _ []) = pure 1
depth (Array _ xs) = (1+) . maximum <$> mapM (depth . fromScalar) xs
depth' :: MonadError Error m => Array -> m Array
depth' = fmap (scalar . Number . fromInteger . toInteger) . depth
```

## Changes in the JS Interpreter

I added an interface to `tinyapl.js`

that allows for custom quad nilads and functions to be created from the JavaScript side; for now the implemented quads are `⎕CreateImage`

, `⎕DisplayImage`

, `⎕PlayAnimation`

, `⎕ScatterPlot`

, `⎕PlayAudio`

, `⎕Fetch`

. They're explained in more depth in the info section on the interpreter (which is here). Here are some examples:

The interface is also now more usable, with features such as Shift + ↑/↓ to cycle between previously ran lines and an info section explaining how to use the interpreter.

`⎕Delay`

Very simple quad: delays for approximately `y`

seconds and returns the actual time.

```
delay = Function (Just $ \x -> do
let err = DomainError "Delay argument must be a nonnegative scalar number"
n <- asScalar err x >>= asNumber err >>= asReal err
if n < 0 then throwError err else do
start <- realToFrac <$> liftToSt getPOSIXTime
liftToSt $ threadDelay $ floor $ n * 1000 * 1000
end <- realToFrac <$> liftToSt getPOSIXTime
pure $ scalar $ Number $ (end - start) :+ 0
) Nothing (G.quad : "Delay")
```

## The first PR!

I switched to Megaparsec for tokenization, this involved a few changes mostly in the way errors are formatted. However, I was dissatisfied with the way errors were signaled, such as that when assigning something that causes a parse error, the error is indicated at the point of the assignment instead. Talking about this on the APL Farm, Discord user Probie (who goes by `@LudvikGalois`

on GitHub) decided to open a pull request fixing the issue! The problem turned out to be excessive use of `try`

in the parser. They also changed the code to use `lexeme`

instead of raw `between whitespace whitespace`

. Thanks a lot to them for the help!

## Ties

One annoying thing I've found writing the examples for testing out the image and animation features is the fact that writing vectors is quite verbose. While I think that isn't as much of a problem with large elements, it gets a bit *too* verbose with simple numeric vectors. I've introduced a Tie syntax `‿`

for number vectors. The changes are quite easy:

```
data Token
= TokenNumber [(Complex Double)] SourcePos
-- ...
```

```
number = withPos $ TokenNumber <$> sepBy1 complex (lexeme $ char G.tie) where -- ...
```

```
evalLeaf (TokenNumber [x] _) = return $ VArray $ scalar $ Number x
evalLeaf (TokenNumber xs _) = return $ VArray $ vector $ Number <$> xs
```

## Mirror, Left Fork, Right Fork

Mirror, Left Fork and Right Fork are three new-to-APL combinators I designed. Mirror is, as far as I can tell, never implemented; while Left and Right Fork appear in Uiua as special cases of the combinators `⟜ on`

and `⊸ by`

. Mirror has appeared in the planning months ago, Left and Right Fork are new.

Mirror gets the glpyh `⸚`

, Left Fork `⇾`

and Right Fork `⇽`

(Yes, Left Fork is a right-pointing arrow. I put them this way to mirror `⟜⊸`

which have their direction taken from BQN). Monadically, Left and Right Fork act as the corresponding Hook, Mirror isn't defined.

```
mirror :: MonadError Error m => (b -> b -> m c) -> (a -> a -> m b) -> a -> a -> m c
mirror f g x y = do
b <- g x y
a <- g y x
f a b
leftFork :: MonadError Error m => (a -> b -> m c) -> (c -> b -> m d) -> a -> b -> m d
leftFork f g x y = do
a <- f x y
g a y
rightFork :: MonadError Error m => (a -> c -> m d) -> (a -> b -> m c) -> a -> b -> m d
rightFork f g x y = do
a <- g x y
f x a
```

## Trains

As mentioned before, TinyAPL puts its spin on the traditional train syntax. It is, of course, mostly to simplify parsing; it does introduce some nice bonuses though. Syntax uses `⦅⋄⦆`

, with each tine separated by a diamond.

The first bonus is that empty tines can be allowed in the syntax: this is interpreted the same way Cap `[:`

is in J trains: it forces a 3-train to be a 2-train instead. This is useful for longer trains: compare `⦅-⋄+⋄-⦆`

(a fork: sum the result of the negation of the argument and the negation of the argument; or similar dyadic meaning) with `⦅-⋄⋄+⋄-⦆`

(two atops: negate the result of conjugating the result of the negation of the argument; or similar dyadic meaning).

The second bonus is that "trains" that in other APLs would evaluate to calls, such as `F1 F2 a3`

(which becomes the array `F1 (F2 a3)`

, instead of the function `F1 F2 a3⍨`

) can be interpreted as proper trains.

Another natural choice is to allow J-like ("like" as in I just stole them) modifier trains, i.e. trains where the tines are adverbs or conjunctions. Modifier trains can *result* in modifiers too, which is why the syntax (in TinyAPL style) uses `_⦅⋄⦆`

for adverb-returning trains and `_⦅⋄⦆_`

for conjunction-returning trains.

All combinations are documented on the trains documentation page.

Onto the code:

```
data Token
-- ...
| TokenTrain [Maybe [Token]] SourcePos
| TokenAdverbTrain [Maybe [Token]] SourcePos
| TokenConjunctionTrain [Maybe[Token]] SourcePos
```

```
train :: Parser Token
train = withPos $ TokenTrain <$> (string [fst G.train] *> sepBy1 (option Nothing $ Just <$> bits) separator <* string [snd G.train])
adverbTrain :: Parser Token
adverbTrain = withPos $ TokenAdverbTrain <$> (string [G.underscore, fst G.train] *> sepBy1 (option Nothing $ Just <$> bits) separator <* string [snd G.train] <* notFollowedBy (char G.underscore))
conjunctionTrain :: Parser Token
conjunctionTrain = withPos $ TokenConjunctionTrain <$> (string [G.underscore, fst G.train] *> sepBy1 (option Nothing $ Just <$> bits) separator <* string [snd G.train, G.underscore])
```

```
train :: Category -> [Maybe [Token]] -> SourcePos -> Result Tree
train cat es _ = TrainBranch cat <$> (mapM (\case
Nothing -> return Nothing
Just y -> Just <$> categorizeAndBind y
) es)
tokenToTree (TokenTrain fs pos) = train CatFunction fs pos
tokenToTree (TokenAdverbTrain fs pos) = train CatAdverb fs pos
tokenToTree (TokenConjunctionTrain fs pos) = train CatConjunction fs pos
```

```
evalTrain :: Category -> [Maybe Tree] -> St Value
evalTrain cat es = let
atop :: Function -> Function -> Function
atop f g = Function { functionMonad = Just $ F.compose (callMonad f) (callMonad g), functionDyad = Just $ F.atop (callMonad f) (callDyad g), functionRepr = "" }
fork :: Function -> Function -> Function -> Function
fork f g h = Function { functionMonad = Just $ F.fork1 (callMonad f) (callDyad g) (callMonad h), functionDyad = Just $ F.fork2 (callDyad g) (callDyad f) (callDyad h), functionRepr = "" }
bindLeft :: Function -> Array -> Function
bindLeft f x = Function { functionMonad = Just $ \y -> callDyad f x y, functionDyad = Nothing, functionRepr = "" }
bindRight :: Function -> Array -> Function
bindRight f y = Function { functionMonad = Just $ \x -> callDyad f x y, functionDyad = Nothing, functionRepr = "" }
train1 :: Value -> St Value
train1 (VArray x) = pure $ VFunction $ Function { functionMonad = Just $ F.constant1 x, functionDyad = Just $ F.constant2 x, functionRepr = "" }
train1 o = pure $ o
train2 :: Value -> Value -> St Value
train2 (VArray x) (VArray _) = pure $ VFunction $ Function { functionMonad = Just $ F.constant1 x, functionDyad = Just $ F.constant2 x, functionRepr = "" }
-- ...
train2 (VConjunction c) (VConjunction d) = pure $ VConjunction $ makeValueConjunction (\u v -> do
a <- callOnValueAndValue d u v
b <- callOnValueAndValue c u v
pure $ atop a b) ""
train2 x y = throwError $ DomainError $ "2-train with " ++ show x ++ " and " ++ show y ++ "?"
train3 :: Value -> Value -> Value -> St Value
train3 (VArray _) (VArray y) (VArray _) = pure $ VFunction $ Function { functionMonad = Just $ F.constant1 y, functionDyad = Just $ F.constant2 y, functionRepr = "" }
-- ...
train3 (VConjunction c) (VConjunction d) (VConjunction e) = pure $ VConjunction $ makeValueConjunction (\u v -> do
r <- callOnValueAndValue e u v
s <- callOnValueAndValue c u v
callOnFunctionAndFunction d s r) ""
train3 x y z = throwError $ DomainError $ "3-train with " ++ show x ++ ", " ++ show y ++ " and " ++ show z ++ "?"
train :: [Maybe Value] -> St Value
train [] = throwError $ DomainError "Empty train"
train [Nothing] = throwError $ DomainError "Empty train"
train [Just x] = train1 x
train [Just y, Just x] = train2 x y
train [_, _] = throwError $ SyntaxError "2-train cannot contain empty entries"
train (Just z : Just y : Just x : rs) = train3 x y z >>= train . (: rs) . Just
train (Just z : Just y : Nothing : rs) = train2 y z >>= train . (: rs) . Just
train _ = throwError $ SyntaxError "3-train can only contain empty entries as the first tine"
withTrainRepr :: [Maybe Value] -> Value -> St Value
withTrainRepr _ (VArray _) = throwError $ DomainError "Array train?"
withTrainRepr us (VFunction f) = pure $ VFunction $ f{ functionRepr = [fst G.train] ++ intercalate [' ', G.separator, ' '] (show <$> us) ++ [snd G.train] }
withTrainRepr us (VAdverb a) = pure $ VAdverb $ a{ adverbRepr = [G.underscore, fst G.train] ++ intercalate [' ', G.separator, ' '] (show <$> us) ++ [snd G.train] }
withTrainRepr us (VConjunction c) = pure $ VConjunction $ c{ conjRepr = [G.underscore, fst G.train] ++ intercalate [' ', G.separator, ' '] (show <$> us) ++ [snd G.train, G.underscore] }
in do
us <- mapM (\case
Nothing -> pure Nothing
Just x -> Just <$> eval x) es
t <- train $ reverse us
r <- withTrainRepr us t
case (cat, r) of
(CatArray, _) -> throwError $ DomainError "Array train?"
(CatFunction, r@(VFunction _)) -> pure r
(CatAdverb, r@(VAdverb _)) -> pure r
(CatConjunction, r@(VConjunction _)) -> pure r
(exp, g) -> throwError $ DomainError $ "Expected train of category " ++ show exp ++ ", got a " ++ show (valueCategory g)
```