Another big missing thing in TinyAPL is the At Depth conjunction. I've never felt the need for it until I actually tried using it in BQN and realized how nice of a feature it is. The most useful usecase is depth-0, which in TinyAPL is made even easier with the On Simple Scalars adverb ⌓. Adám has also suggested I look into ordering again and so I did.
Just like every time, all the code in this post is also available on GitHub.
Array Cast feature
Earlier I said Adám suggested I change ordering, but he didn't just suggest me via the Orchard nor the Farm, instead we chatted on the Array Cast, where I was invited to talk about TinyAPL! You can listen to the episode here (it's episode 88). I'm really proud of being invited (less proud of my performance(: ) and getting to discuss a lot of choices I made. If you want to hear a long discussion about my trains and how maybe they're not really trains, that episode is for you.
Laminate
Laminate, the really useful and yet easy to implement primitive, which you might also know as Couple from BQN and Uiua.
laminate :: MonadError Error m => Array -> Array -> m Array
laminate = catenate `over` promote
Mix and Major Cells
Having implemented At Rank a few posts ago, these are made really easy:
majorCells' :: MonadError Error m => Array -> m Array
majorCells' = pure . vector . fmap box . majorCells
mix :: MonadError Error m => Array -> m Array
mix = atRank1 first 0
At Depth and On Simple Scalars
Monad At Depth works similarly to how monad At Rank works, of course checking for depth instead of rank:
atDepth1 :: MonadError Error m => (Array -> m Array) -> Integer -> Array -> m Array
atDepth1 f depth arr
| arrayDepth arr == 0 || (depth >= 0 && toInteger (arrayDepth arr) <= depth) = f arr
| depth == -1 = each1 f arr
| otherwise = each1 (atDepth1 f $ depth + (if depth < 0 then 1 else 0)) arr
Dyad At Depth is a bit more complex. I found it easier to write an inner recursive function that treats a depth target of 0 as not wanting depth 0 but the current depth (so it's kinda like if it was ¯0):
atDepth2 f (da, db) a b = go f (if da == 0 then likeNegativeInfinity else da, if db == 0 then likeNegativeInfinity else db) a b where
go f (da, db) a b = let
leftPure = da == 0 || arrayDepth a == 0 || (da >= 0 && toInteger (arrayDepth a) <= da)
rightPure = db == 0 || arrayDepth b == 0 || (db >= 0 && toInteger (arrayDepth b) <= db)
in case (leftPure, rightPure) of
(True, True) -> f a b
(True, False) -> atDepth1 (a `f`) db b
(False, True) -> atDepth1 (`f` b) da a
(False, False) -> each2 (go f (da + (if da < 0 then 1 else 0), db + (if db < 0 then 1 else 0))) a b
If only one of the arguments has to deepen, it uses monad At Depth, if both it recurses on the inner function with an Each.
On Simple Scalars is now trivial:
onSimpleScalars1 :: MonadError Error m => (Array -> m Array) -> Array -> m Array
onSimpleScalars1 f = atDepth1 f 0
onSimpleScalars2 :: MonadError Error m => (Array -> Array -> m Array) -> Array -> Array -> m Array
onSimpleScalars2 f = atDepth2 f (0, 0)
Ordering scalars
Currently, comparing wraps and structs is a bit useless: they are never equal to each other and wraps order by representation of the inner function. While solving this for structs requires more work and will probably be the highlight of another post, fixing it for wraps is easier.
The Function, Adverb and Conjunction datas have been turned into a series of cases that represent a way of creating that type:
data Function
= DefinedFunction
{ functionMonad :: Maybe (Array -> St Array)
, functionDyad :: Maybe (Array -> Array -> St Array)
, functionRepr :: String
, functionContext :: Maybe Context
, definedFunctionId :: Integer }
| PrimitiveFunction
{ functionMonad :: Maybe (Array -> St Array)
, functionDyad :: Maybe (Array -> Array -> St Array)
, functionRepr :: String
, functionContext :: Maybe Context }
| PartialFunction
{ functionMonad :: Maybe (Array -> St Array)
, functionDyad :: Maybe (Array -> Array -> St Array)
, functionContext :: Maybe Context
, partialFunctionFunction :: Function
, partialFunctionLeft :: Array }
| DerivedFunctionArray
{ functionMonad :: Maybe (Array -> St Array)
, functionDyad :: Maybe (Array -> Array -> St Array)
, functionContext :: Maybe Context
, derivedFunctionAdverb :: Adverb
, derivedFunctionArrayLeft :: Array }
| DerivedFunctionFunction
{ functionMonad :: Maybe (Array -> St Array)
, functionDyad :: Maybe (Array -> Array -> St Array)
, functionContext :: Maybe Context
, derivedFunctionAdverb :: Adverb
, derivedFunctionFunctionLeft :: Function }
| DerivedFunctionArrayArray
{ functionMonad :: Maybe (Array -> St Array)
, functionDyad :: Maybe (Array -> Array -> St Array)
, functionContext :: Maybe Context
, derivedFunctionConjunction :: Conjunction
, derivedFunctionArrayLeft :: Array
, derivedFunctionArrayRight :: Array }
| DerivedFunctionArrayFunction
{ functionMonad :: Maybe (Array -> St Array)
, functionDyad :: Maybe (Array -> Array -> St Array)
, functionContext :: Maybe Context
, derivedFunctionConjunction :: Conjunction
, derivedFunctionArrayLeft :: Array
, derivedFunctionFunctionRight :: Function }
| DerivedFunctionFunctionArray
{ functionMonad :: Maybe (Array -> St Array)
, functionDyad :: Maybe (Array -> Array -> St Array)
, functionContext :: Maybe Context
, derivedFunctionConjunction :: Conjunction
, derivedFunctionFunctionLeft :: Function
, derivedFunctionArrayRight :: Array }
| DerivedFunctionFunctionFunction
{ functionMonad :: Maybe (Array -> St Array)
, functionDyad :: Maybe (Array -> Array -> St Array)
, functionContext :: Maybe Context
, derivedFunctionConjunction :: Conjunction
, derivedFunctionFunctionLeft :: Function
, derivedFunctionFunctionRight :: Function }
| UnwrapArrayFunction
{ functionMonad :: Maybe (Array -> St Array)
, functionDyad :: Maybe (Array -> Array -> St Array)
, functionContext :: Maybe Context
, unwrapFunctionArray :: Array }
| TrainFunction
{ functionMonad :: Maybe (Array -> St Array)
, functionDyad :: Maybe (Array -> Array -> St Array)
, functionContext :: Maybe Context
, trainFunctionTines :: [Maybe Value] }
deriving (Generic, NFData)
data Adverb
= DefinedAdverb
{ adverbOnArray :: Maybe (Array -> St Function)
, adverbOnFunction :: Maybe (Function -> St Function)
, adverbRepr :: String
, adverbContext :: Maybe Context
, definedAdverbId :: Integer }
| PrimitiveAdverb
{ adverbOnArray :: Maybe (Array -> St Function)
, adverbOnFunction :: Maybe (Function -> St Function)
, adverbRepr :: String
, adverbContext :: Maybe Context }
| PartialAdverb
{ adverbOnArray :: Maybe (Array -> St Function)
, adverbOnFunction :: Maybe (Function -> St Function)
, adverbContext :: Maybe Context
, partialAdverbConjunction :: Conjunction
, partialAdverbRight :: Value }
| TrainAdverb
{ adverbOnArray :: Maybe (Array -> St Function)
, adverbOnFunction :: Maybe (Function -> St Function)
, adverbContext :: Maybe Context
, trainAdverbTines :: [Maybe Value] }
data Conjunction
= DefinedConjunction
{ conjOnArrayArray :: Maybe (Array -> Array -> St Function)
, conjOnArrayFunction :: Maybe (Array -> Function -> St Function)
, conjOnFunctionArray :: Maybe (Function -> Array -> St Function)
, conjOnFunctionFunction :: Maybe (Function -> Function -> St Function)
, conjRepr :: String
, conjContext :: Maybe Context
, definedConjunctionId :: Integer }
| PrimitiveConjunction
{ conjOnArrayArray :: Maybe (Array -> Array -> St Function)
, conjOnArrayFunction :: Maybe (Array -> Function -> St Function)
, conjOnFunctionArray :: Maybe (Function -> Array -> St Function)
, conjOnFunctionFunction :: Maybe (Function -> Function -> St Function)
, conjRepr :: String
, conjContext :: Maybe Context }
| TrainConjunction
{ conjOnArrayArray :: Maybe (Array -> Array -> St Function)
, conjOnArrayFunction :: Maybe (Array -> Function -> St Function)
, conjOnFunctionArray :: Maybe (Function -> Array -> St Function)
, conjOnFunctionFunction :: Maybe (Function -> Function -> St Function)
, conjContext :: Maybe Context
, trainConjunctionTines :: [Maybe Value] }
deriving (Generic, NFData)
Ordering functions and therefore wraps is now trivial: primitives order by glyph, derived functions compare their modifer and then the arguments. Defined functions (i.e. dfns) compare by definedFunctionId, an incremental id assigned to each dfn when creating them (stored in Context): functions with the same id compare equal, which means they are compared by "reference equality". Same goes for adverbs and conjunctions
Infinity
In Dyalog, if you want a function to apply to vectors of one arguments and whole arrays of the other argument, you have to write F⍤1 99. Why 99? Because that's a number that exceeds the maximum rank allowed and therefore acts as "whatever rank". Other languages like BQN solve this by using infinities: F⎉1‿∞. Here I introduce this syntax to TinyAPL.
real :: Parser Double
real = choice [string [G.infinity] $> inf, string [G.negative, G.infinity] $> ninf, scientific]
complex :: Parser (Complex Double)
complex = liftA2 (:+) real (option 0 (char G.imaginary *> real))
asInt' e x
| isInfinite x && x > 0 = pure likePositiveInfinity
| isInfinite x && x < 0 = pure likeNegativeInfinity
likePositiveInfinity and likeNegativeInfinity are just big integers that should be large enough for all your needs:
-- These need to be somewhat large
likePositiveInfinity :: Integral num => num
likePositiveInfinity = fromInteger $ toInteger (maxBound `div` 2 :: Int)
likeNegativeInfinity :: Integral num => num
likeNegativeInfinity = fromInteger $ toInteger (minBound `div` 2 :: Int)
Ordering arrays
Currently, array ordering isn't well thought out. As mentioned above, I've been pointed to TAO Axioms, a paper which suggests a proper array ordering for Dyalog. I've integrated most of its choices in TinyAPL's array ordering:
instance Ord Array where
(Array [] [a]) `compare` (Array [] [b]) = a `compare` b
(Array [_] []) `compare` (Array [_] []) = EQ
(Array [_] []) `compare` (Array [_] _) = LT
(Array [_] _) `compare` (Array [_] []) = GT
(Array [at] (a:as)) `compare` (Array [bt] (b:bs)) = a `compare` b <> Array [at - 1] as `compare` Array [bt - 1] bs <> at `compare` bt
a@(Array ash acs) `compare` b@(Array bsh bcs)
| arrayRank a < arrayRank b = (Array (genericReplicate (arrayRank b - arrayRank a) 1 ++ ash) acs) `compare` b <> LT
| arrayRank a > arrayRank b = a `compare` (Array (genericReplicate (arrayRank a - arrayRank b) 1 ++ bsh) bcs) <> GT
| otherwise = mconcat (zipWith compare (majorCells a) (majorCells b)) <> fromMaybe 1 (listToMaybe ash) `compare` fromMaybe 1 (listToMaybe bsh)
And that's it!