Back to Index Page

# TinyAPL part 3: More Primitives

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  []
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)
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.