Back to Index Page

# TinyAPL part 2: Functions & Operators

In this post, I will add functions and operators to the Haskell representation of TinyAPL.

This code is also available as a GitHub repository.

## Splitting modules & fixing Show

I moved most of the code from the last article into TinyAPL.Array, except for error-related things which went into TinyAPL.Error, and .: which is in TinyAPL.Util. I also added a ton more glyphs to TinyAPL.Glyphs, which we will use throughout the article. I also wrote the following function, which is in TinyAPL.Util:

showAplDouble :: Double -> String
showAplDouble x
| isNaN x = "<NaN>"
| isInfinite x = if x > 0 then [G.infinity] else [G.negative, G.infinity]
| floor x == ceiling x = let
isNegative = x < 0
pos = show $truncateDoubleInteger$ abs x
in if isNegative then G.negative : pos else pos
| otherwise = let
isNegative = x < 0
x' = abs x
(is, e) = floatToDigits 10 x'
ds = intToDigit <$> is pos = if e < 0 || e > 7 then let e' = e - 1 show_e' = (if e' < 0 then [G.exponent, G.negative] else [G.exponent]) ++ show (abs e') in case ds of "0" -> "0" [d] -> d : show_e' (d:ds') -> d : '.' : ds' ++ show_e' else let mk0 "" = "0" mk0 xs = xs f 0 s rs = mk0 (reverse s) ++ '.' : mk0 rs f n s "" = f (n - 1) ('0' : s) "" f n s (r:rs) = f (n - 1) (r : s) rs in f e "" ds in if isNegative then G.negative : pos else pos  It is somewhat a calque of the double-showing functions in base, just using APL glyphs instead. I use it when showing Numbers: showComplex (a :+ b) | b realEqual 0 = showAplDouble a | otherwise = showAplDouble a ++ [G.imaginary] ++ showAplDouble b  ## Functions module TinyAPL.Function where  Functions can be called either as a monad or as a dyad (or potentially both). They also need an intrinsic representation. data Function = DefinedFunction { dfnMonad :: Maybe (Array -> Result Array) , dfnDyad :: Maybe (Array -> Array -> Result Array) , dfnRepr :: String }  You'll see later why we call these DefinedFunctions. instance Show Function where show (DefinedFunction { dfnRepr = repr }) = "<fn " ++ repr ++ ">" callMonad :: Function -> Array -> Result Array callMonad (DefinedFunction (Just f) _ _) x = f x callMonad f@(DefinedFunction Nothing _ _) = err$ DomainError $"Function " ++ show f ++ " cannot be called monadically." callDyad :: Function -> Array -> Array -> Result Array callDyad (DefinedFunction _ (Just g) _) a b = g a b callDyad f@(DefinedFunction _ Nothing _) _ _ = err$ DomainError $"Function " ++ show f ++ " cannot be called dyadically."  We can now start defining primitive functions. ## Primitive functions module TinyAPL.Primitives where  These are quite boring and there isn't much to talk about anyways, so here's a listing of all the primitives that were easy to implement. plus = DefinedFunction (Just$ monadN2N' conjugate) (Just $dyadNN2N' (+)) [G.plus] minus = DefinedFunction (Just$ monadN2N' negate) (Just $dyadNN2N' (-)) [G.minus] times = DefinedFunction (Just$ monadN2N' signum) (Just $dyadNN2N' (*)) [G.times] divide = DefinedFunction (Just$ monadN2N $\case 0 -> err$ DomainError "Divide by zero"
x -> pure $recip x) (Just$ dyadNN2N $\cases 0 0 -> pure 1 _ 0 -> err$ DomainError "Divide by zero"
x y -> pure $x / y) [G.divide] power = DefinedFunction (Just$ monadN2N' exp) (Just $dyadNN2N' (**)) [G.power] logarithm = DefinedFunction (Just$ monadN2N $\case 0 -> err$ DomainError "Logarithm of zero"
x -> pure $log x) (Just$ dyadNN2N $\cases 1 1 -> pure 1 1 _ -> err$ DomainError "Logarithm base one"
_ 0 -> err $DomainError "Logarithm of zero" x y -> pure$ logBase x y
) [G.logarithm]
circle = DefinedFunction (Just $monadN2N' (pi *)) (Just$ dyadNN2N' $\cases 0 y -> sqrt$ 1 - y * y
1     y -> sin y
(-1)  y -> asin y
2     y -> cos y
(-2)  y -> acos y
3     y -> tan y
(-3)  y -> atan y
4     y -> sqrt $1 + y * y (-4) y -> sqrt$ y * y - 1
5     y -> sinh y
(-5)  y -> asinh y
6     y -> cosh y
(-6)  y -> acosh y
7     y -> tanh y
(-7)  y -> atanh y
8     y -> sqrt $negate$ 1 + y * y
(-8)  y -> negate $sqrt$ negate $1 + y * y 9 y -> realPart y :+ 0 (-9) y -> y 10 y -> abs y (-10) y -> conjugate y 11 y -> imagPart y :+ 0 (-11) y -> y * (0 :+ 1) 12 y -> phase y :+ 0 (-12) y -> exp$ y * (0 :+ 1)) [G.circle]
root = DefinedFunction (Just $monadN2N' sqrt) (Just$ dyadNN2N' $\x y -> x ** recip y) [G.root] min = DefinedFunction Nothing (Just$ scalarDyad $pure .: Ord.min) [G.floor] max = DefinedFunction Nothing (Just$ scalarDyad $pure .: Ord.max) [G.ceil] less = DefinedFunction Nothing (Just$ scalarDyad $pure .: boolToScalar .: (<)) [G.less] lessEqual = DefinedFunction Nothing (Just$ scalarDyad $pure .: boolToScalar .: (<=)) [G.lessEqual] equal = DefinedFunction Nothing (Just$ scalarDyad $pure .: boolToScalar .: (==)) [G.equal] greaterEqual = DefinedFunction Nothing (Just$ scalarDyad $pure .: boolToScalar .: (>=)) [G.greaterEqual] greater = DefinedFunction Nothing (Just$ scalarDyad $pure .: boolToScalar .: (>)) [G.greater] notEqual = DefinedFunction Nothing (Just$ scalarDyad $pure .: boolToScalar .: (/=)) [G.notEqual] and = DefinedFunction Nothing (Just$ dyadBB2B' (&&)) [G.and]
or = DefinedFunction Nothing (Just $dyadBB2B' (||)) [G.or] nand = DefinedFunction Nothing (Just$ dyadBB2B' $not .: (&&)) [G.nand] nor = DefinedFunction Nothing (Just$ dyadBB2B' $not .: (||)) [G.nor] cartesian = DefinedFunction (Just$ monadN2N' (* (0 :+ 1))) (Just $dyadNN2N'$ \x y -> x + (0 :+ 1) * y) [G.cartesian]
polar = DefinedFunction (Just $monadN2N'$ exp . (* (0 :+ 1))) (Just $dyadNN2N'$ \x y -> x * (exp y * (0 :+ 1))) [G.polar]
match = DefinedFunction Nothing (Just $pure .: scalar .: boolToScalar .: (==)) [G.match] notMatch = DefinedFunction (Just$ pure . genericLength . majorCells) (Just $pure .: scalar .: boolToScalar .: (/=)) [G.notMatch] rho = DefinedFunction (Just$ \(Array sh _) -> pure $vector$ (Number . fromInteger . toEnum . fromEnum) <$> sh) Nothing [G.rho] ravel = DefinedFunction (Just$ pure . vector . arrayContents) Nothing [G.ravel]
reverse = DefinedFunction (Just $onMajorCells$ pure . List.reverse) Nothing [G.reverse]
pair = DefinedFunction (Just $pure . vector . singleton . box) (Just$ \x y -> pure $vector [box x, box y]) [G.pair] enclose = DefinedFunction (Just$ pure . scalar . box) Nothing [G.enclose]
first = DefinedFunction (Just $\case Array _ [] -> err$ DomainError "First on empty array"
Array _ (x:_) -> pure $scalar x) Nothing [G.first] last = DefinedFunction (Just$ \case
Array _ [] -> err $DomainError "Last on empty array" Array _ xs -> pure$ scalar $List.last xs) Nothing [G.last]  onMajorCells is defined in TinyAPL.Array: majorCells :: Array -> [Array] majorCells a@(Array [] _) = [a] majorCells (Array (sh:shs) cs) = catMaybes$ arrayOf shs <$> chunk sh cs where chunk _ [] = [] chunk l xs = genericTake l xs : chunk l (genericDrop l xs) onMajorCells :: ([Array] -> Result [Array]) -> Array -> Result Array onMajorCells f x = do result <- f$ majorCells x
pure $arrayReshaped (arrayShape x)$ concat $arrayContents <$> result


## Operators

module TinyAPL.Operator where


Unlike functions, an operator can only be either monadic or dyadic. Borrowing the terms from J, I call the former adverbs and the latter conjunctions. Why? "monadic operator" and "dyadic operator" are slightly too verbose(1) for my taste :)

data Adverb = Adverb
{ adverbOnArray    :: Maybe (Array    -> Result Function)
, adverbOnFunction :: Maybe (Function -> Result Function)

show (Adverb _ _ repr) = "<adverb " ++ repr ++ ">"

data Conjunction = Conjunction
{ conjOnArrayArray       :: Maybe (Array    -> Array    -> Result Function)
, conjOnArrayFunction    :: Maybe (Array    -> Function -> Result Function)
, conjOnFunctionArray    :: Maybe (Function -> Array    -> Result Function)
, conjOnFunctionFunction :: Maybe (Function -> Function -> Result Function)
, conjRepr               :: String }

instance Show Conjunction where
show (Conjunction _ _ _ _ repr) = "<conj " ++ repr ++ ">"


The code is pretty self-explanatory. Because each operand can either be an array or a function, Conjunctions sadly require five record entries to be modeled.

Now for the verbose stuff:

callOnArray :: Adverb -> Array -> Result Function
callOnArray (Adverb (Just op) _ _) x = op x
callOnArray adv _ = err $DomainError$ "Operator " ++ show adv ++ " does not take array operands."

callOnFunction :: Adverb -> Function -> Result Function
callOnFunction (Adverb _ (Just op) _) x = op x
callOnFunction adv _ = err $DomainError$ "Operator " ++ show adv ++ " does not take functions operands."

callOnArrayAndArray :: Conjunction -> Array -> Array -> Result Function
callOnArrayAndArray (Conjunction (Just op) _ _ _ _) x y = op x y
callOnArrayAndArray conj _ _ =  err $DomainError$ "Operator " ++ show conj ++ " cannot be applied to two arrays."

callOnArrayAndFunction :: Conjunction -> Array -> Function -> Result Function
callOnArrayAndFunction (Conjunction _ (Just op) _ _ _) x y = op x y
callOnArrayAndFunction conj _ _ =  err $DomainError$ "Operator " ++ show conj ++ " cannot be applied to an array and a function."

callOnFunctionAndArray :: Conjunction -> Function -> Array -> Result Function
callOnFunctionAndArray (Conjunction _ _ (Just op) _ _) x y = op x y
callOnFunctionAndArray conj _ _ =  err $DomainError$ "Operator " ++ show conj ++ " cannot be applied to a function and an array."

callOnFunctionAndFunction :: Conjunction -> Function -> Function -> Result Function
callOnFunctionAndFunction (Conjunction _ _ _ (Just op) _) x y = op x y
callOnFunctionAndFunction conj _ _ =  err $DomainError$ "Operator " ++ show conj ++ " cannot be applied to two functions."


## Primitive operators

I decided to add primitve operators as alternate constructors in the Function data to make the code slightly cleaner.

data Function
= DefinedFunction
{ dfnMonad :: Maybe (Array -> Result Array)
, dfnDyad  :: Maybe (Array -> Array -> Result Array)
, dfnRepr  :: String }
| Atop { atopLeft :: Function, atopRight :: Function }
| Over { overLeft :: Function, overRight :: Function }


We can now implement the first two operators, which probably represent the majority of the easy ones (the complicated things like / will get their own posts, don't worry):

atop = Conjunction
{ conjRepr = [G.atop]
, conjOnArrayArray = Nothing
, conjOnArrayFunction = Nothing
, conjOnFunctionArray = Just $\_ _ -> err$ NYIError "Rank operator not implemented yet"
, conjOnFunctionFunction = Just $\f g -> pure$ f Atop g }
over = Conjunction
{ conjRepr = [G.over]
, conjOnArrayArray = Nothing
, conjOnArrayFunction = Nothing
, conjOnFunctionArray = Just $\_ _ -> err$ NYIError "Depth operator not implemented yet"
, conjOnFunctionFunction = Just $\f g -> pure$ f Over g }


And of course, function calls need to support the new constructors:

-- instance Show Function where
show (l Atop r) = "(" ++ show l ++ [G.atop] ++ show r ++ ")"
show (l Over r) = "(" ++ show l ++ [G.over] ++ show r ++ ")"

-- callMonad :: Function -> Array -> Result Array
callMonad (f Atop g) x = callMonad g x >>= callMonad f
callMonad (f Over g) x = callMonad g x >>= callMonad f

-- callDyad :: Function -> Array -> Array -> Result Array
callDyad (f Atop g) a b = callDyad g a b >>= callMonad f
callDyad (f Over g) a b = do