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)