TinyAPL part 2: Functions & Operators

#tinyapl#apl#haskell

Madeline Vergani

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)
  , adverbRepr       :: String }

instance Show Adverb where
  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
  a' <- callMonad g a
  b' <- callMonad g b
  callDyad f a' b'

Footnotes

  1. But if you like verbose things, you'll love what's about to come.