In this post I implement some of the less intuitive primitives for TinyAPL.
As usual, all code is available as a GitHub repository
majorCells bug
Currently, the implementation of majorCells is completely wrong. It tries to chunk an array into pieces of length head shape, where it should instead make head shape-many chunks, or equivalently chunks of length product $ tail shape.
majorCells :: Array -> [Array]
majorCells a@(Array [] _) = [a]
majorCells (Array (_:sh) cs) = mapMaybe (arrayOf sh $ chunk (product sh) cs where
chunk _ [] = []
chunk l xs = genericTake l xs : chunk l (genericDrop l xs)
Reshape
First, we need a function to unwrap an array into a vector:
asVector :: Error -> Array -> Result [ScalarValue]
asVector _ (Array [] scalar) = pure scalar
asVector _ (Array [_] vec) = pure vec
asVector e _ = err e
As well as the count utility function:
count :: Num n => (a -> Bool) -> [a] -> n
count _ [] = 0
count p (x:xs) | p x = 1 + count p xs
| otherwise = count p xs
The implementation is made slightly more complicated by my choice to implement the extension that allows ¯1 to be used as one of the elements of the shape to be automatically adjusted to the needed amount.
-- as argument to rho = DefinedFunction
\sh (Array _ xs) -> do
let mustBeIntegral = DomainError "Shape must be integral"
shape <- (asVector (RankError "Shape must be a vector") sh >>=
mapM (asNumber mustBeIntegral >=> asInt mustBeIntegral)) :: Result [Integer]
let negative = count (< 0) shape
If there is no ¯1, we can just use the arrayReshaped function:
if negative == 0 then pure $ arrayReshaped (toEnum . fromEnum <$> shape) xs
Otherwise, -1 is replaced by the bound of the original array modulo the product of the other elements of the new shape.
else if negative == 1 && (-1) `elem` shape then do
let allElements = genericLength xs
let known = product $ filter (>= 0) shape
if known == 0 then err $ DomainError $ "Shape cannot and contain both 0 and " ++ [G.negative] ++ "1"
else if allElements `mod` known /= 0 then err $ DomainError "Shape is not a multiple of the bound of the array"
else pure $ arrayReshaped (toEnum . fromEnum <$> map (\x -> if x == (-1) then allElements `div` known else x) shape) xs
else err $ DomainError "Invalid shape"
Take & Drop
Overtaking cannot be implemented yet. When array prototypes will be added, the implementation will be revised.
take = DefinedFunction Nothing (Just $ \t arr -> let
) [G.take]
First, we need a take that behaves like APL's for negative numbers:
take' c = if c < 0 then List.reverse . genericTake (negate c) . List.reverse else genericTake c
We also need a way to undo what majorCells does:
fromMajorCells :: [Array] -> Array
fromMajorCells [] = Array [0] []
fromMajorCells (c:cs) = arrayReshaped (1 + genericLength cs : arrayShape c) $ concatMap arrayContents $ c : cs
And the inner recursive definition for take:
go [] xs = xs
go (t:ts) xs = fromMajorCells $ take' t $ go ts <$> majorCells xs
Finally, parsing:
mustBeIntegral = DomainError "Take left argument must be integral"
in do
ts <- asVector (RankError "Take left argument must be a vector") t >>= mapM (asNumber mustBeIntegral >=> asInt mustBeIntegral)
pure $ go ts arr
The implementation for drop is very similar:
drop = DefinedFunction Nothing (Just $ \d arr -> let
drop' c = if c < 0 then List.reverse . genericDrop (negate c) . List.reverse else genericDrop c
go [] xs = xs
go (d:ds) xs = fromMajorCells $ drop' d $ go ds <$> majorCells xs
mustBeIntegral = DomainError "Drop left argument must be integral"
in do
ds <- asVector (RankError "Drop left argument must be a vector") t >>= mapM (asNumber mustBeIntegral >=> asInt mustBeIntegral)
pure $ go ds arr
) [G.drop]
Left & Right
I kinda just forgot these in the last post :)
left = DefinedFunction (Just $ \x -> pure x) (Just $ \x _ -> pure x) [G.left]
right = DefinedFunction (Just $ \x -> pure x) (Just $ \_ y -> pure y) [G.right]
Combinators
After/Bind ∘:
-- as constructors to Function
| After { afterLeft :: Function, afterRight :: Function }
| BindLeft { bindLeftArray :: Array, bindLeftFunction :: Function }
| BindRight { bindRightFunction :: Function, bindRightArray :: Array }
show (l `After` r) = "(" ++ show l ++ [G.after] ++ show r ++ ")"
show (l `BindLeft` r) = "(" ++ show l ++ [G.after] ++ show r ++ ")"
show (l `BindRight` r) = "(" ++ show l ++ [G.after] ++ show r ++ ")"
callMonad (f `After` g) x = callMonad g x >>= callMonad f
callMonad (a `BindLeft` f) x = callDyad f a x
callMonad (f `BindRight` a) x = callDyad f x a
callDyad (f `After` g) a b = do
b' <- callMonad g b
callDyad f a b'
callDyad (_ `BindLeft` _) _ _ = err $ DomainError "Bound function called dyadically"
callDyad (_ `BindRight` _) _ _ = err $ DomainError "Bound function called dyadically"
after = Conjunction
{ conjRepr = [G.after]
, conjOnArrayArray = Nothing
, conjOnArrayFunction = Just $ \a f -> pure $ a `BindLeft` f
, conjOnFunctionArray = Just $ \f a -> pure $ f `BindRight` a
, conjOnFunctionFunction = Just $ \f g -> pure $ f `After` g }
Before ⍛ (with array operand, acts as default argument):
Unlike other APLs, Before is not a hook (those are separate operators).
-- as constructors to Function
| Before { beforeLeft :: Function, beforeRight :: Function }
| DefaultBindLeft { defaultBindLeftArray :: Array, defaultBindLeftFunction :: Function }
| DefaultBindRight { defaultBindRightFunction :: Function, defaultBindRightArray :: Array }
show (l `Before` r) = "(" ++ show l ++ [G.before] ++ show r ++ ")"
show (l `DefaultBindLeft` r) = "(" ++ show l ++ [G.before] ++ show r ++ ")"
show (l `DefaultBindRight` r) = "(" ++ show l ++ [G.before] ++ show r ++ ")"
callMonad (f `Before` g) x = callMonad f x >>= callMonad g
callMonad (a `DefaultBindLeft` f) x = callDyad f a x
callMonad (f `DefaultBindRight` a) x = callDyad f x a
callDyad (f `Before` g) a b = do
a' <- callMonad f a
callDyad g a' b
callDyad (_ `DefaultBindLeft` f) x y = callDyad f x y
callDyad (f `DefaultBindRight` _) x y = callDyad f x y
before = Conjunction
{ conjRepr = [G.before]
, conjOnArrayArray = Nothing
, conjOnArrayFunction = Just $ \a f -> pure $ a `DefaultBindLeft` f
, conjOnFunctionArray = Just $ \f a -> pure $ f `DefaultBindRight` a
, conjOnFunctionFunction = Just $ \f g -> pure $ f `Before` g }
Left ⊸ and right hooks ⟜:
-- as constructors to Function
| LeftHook { leftHookLeft :: Function, leftHookRight :: Function }
| RightHook { rightHookLeft :: Function, rightHookRight :: Function }
show (l `LeftHook` r) = "(" ++ show l ++ [G.leftHook] ++ show r ++ ")"
show (l `RightHook` r) = "(" ++ show l ++ [G.rightHook] ++ show r ++ ")"
callMonad (f `LeftHook` g) x = do
x' <- callMonad f x
callDyad g x' x
callMonad (f `RightHook` g) x = do
x' <- callMonad g x
callDyad f x x'
callDyad (f `LeftHook` g) a b = do
a' <- callMonad f a
callDyad g a' b
callDyad (f `RightHook` g) a b = do
b' <- callMonad g b
callDyad f a b'
leftHook = Conjunction
{ conjRepr = [G.leftHook]
, conjOnArrayArray = Nothing
, conjOnArrayFunction = Nothing
, conjOnFunctionArray = Nothing
, conjOnFunctionFunction = Just $ \f g -> pure $ f `LeftHook` g }
rightHook = Conjunction
{ conjRepr = [G.rightHook]
, conjOnArrayArray = Nothing
, conjOnArrayFunction = Nothing
, conjOnFunctionArray = Nothing
, conjOnFunctionFunction = Just $ \f g -> pure $ f `RightHook` g }
Selife/Constant ⍨:
-- as constructors to Function
| Selfie { selfieFunction :: Function }
| Constant { constantArray :: Array }
show (Selfie f) = show f ++ [G.selfie]
show (Constant x) = show x ++ [G.selfie]
callMonad (Selfie f) x = callDyad f x x
callMonad (Constant x) _ = pure x
callDyad (Selfie f) a b = callDyad f b a
callDyad (Constant x) _ _ = pure x
selfie = Adverb
{ adverbRepr = [G.selfie]
, adverbOnArray = Just $ \x -> pure $ Constant x
, adverbOnFunction = Just $ \f -> pure $ Selfie f }
Index Generator
This is the first function that is related to indices. It therefore requires an index origin. TinyAPL's index origin will be non-configurable, and set to 1.
The crux of Iota is the following function, that takes the length of the axes and creates a flat list of indices.
generateIndices :: (Enum a, Num a) => [a] -> [[a]]
generateIndices = foldr (liftA2 (:) . enumFromTo 1) [[]]
It works because the Applicative instance for lists has liftA2 be the (flat) cartesian product. Starting from an empty list [[]], each axis length is turned into the list [1..len] and cartesian-multiplied onto the previous results, prepending each value to the built lists.
The rest of the function is just glue for going from/to Arrays.
iota = DefinedFunction (Just $ \x -> do
let error = DomainError "Index Generator requires a vector (or scalar) of natural numbers"
vec <- asVector error x >>= mapM (asNumber error >=> asNat error)
let indices = generateIndices vec
return $ arrayReshaped vec $ box . arrayReshaped (arrayShape x) . fmap (Number . fromInteger . toEnum . fromEnum) <$> indices
) Nothing [G.iota]
Indices
We already have all the building blocks for the function, the only required step is combining them correctly.
indices = DefinedFunction (Just $ \(Array sh cs) -> do
let error = DomainError "Indices requires an array of naturals"
let indices = generateIndices sh
let shape = if length sh == 1 then [] else [genericLength sh]
let rep idx c = genericReplicate c $ box $ arrayReshaped shape $ Number . fromInteger . toEnum . fromEnum <$> idx
counts <- mapM (asNumber error >=> asNat error) cs
return $ vector $ concat $ zipWith rep indices counts
) Nothing [G.indices]
Note that Indices on a vector returns scalars and not boxed singleton vectors.