TinyAPL part 11: Bases and Searching

#tinyapl#apl#haskell

Madeline Vergani

Now that TinyAPL is usable, I've been writing lots of code in it to test it and the functions I've been definitely missing the most are the base conversion functions (Encode and Decode) and the search functions (Element Of and Index Of, mostly). Let's fix that!

Just as usual, all the code here is available on GitHub.

Ternaries

Ternaries are just like those in JavaScript or whatever: based on a condition, return one of two expressions. They use the glyphs ⍰ and ⍠.

data Token
  = TokenNumber (Complex Double) SourcePos
-- ...
  | TokenTernary (NonEmpty Token) (NonEmpty Token) (NonEmpty Token) SourcePos

	bits = spaceConsumer *> (do
    one <- NE.some1 bit
    option one $ fmap NE.singleton $ withPos $ do
      char $ fst G.ternary
      two <- NE.some1 bit
      char $ snd G.ternary
      three <- NE.some1 bit
      pure $ TokenTernary one two three)

data Tree
  = Leaf { leafCategory :: Category, leafToken :: Token }
-- ...
  | TernaryBranch { ternaryBranchCondition :: Tree, ternaryBranchTrue :: Tree, ternaryBranchFalse :: Tree }

	ternary :: NonEmpty Token -> NonEmpty Token -> NonEmpty Token -> Result Tree
  ternary h t f = do
    cond <- categorizeAndBind h >>= requireOfCategory CatArray (\c -> makeSyntaxError (tokenPos $ NE.head h) source $ "Invalid ternary condition of type " ++ show c ++ ", array required")
    true <- categorizeAndBind t >>= requireOfCategory CatArray (\c -> makeSyntaxError (tokenPos $ NE.head t) source $ "Invalid ternary true of type " ++ show c ++ ", array required")
    false <- categorizeAndBind f >>= requireOfCategory CatArray (\c -> makeSyntaxError (tokenPos $ NE.head f) source $ "Invalid ternary false of type " ++ show c ++ ", array required")
    pure $ TernaryBranch cond true false

	tokenToTree (TokenTernary c t f _)                        = ternary c t f

eval (TernaryBranch cond true false) = do
  let err = DomainError "Ternary condition must be a scalar boolean"
  c <- eval cond >>= unwrapArray err >>= asScalar err >>= asBool err
  if c then eval true else eval false

Note that the branch that doesn't get selected doesn't even get evaluated! This means you can refer to potentially undefined variables that you checked for in the condition.

System Info

⎕systemInfo is a very simple quad struct that returns the OS and architecture (as returned by System.Info, for now) and whether the code is being ran in the JS interpreter. Just like ⎕Import, it is exported as a constructor to allow for different executables to pass different inputs.

makeSystemInfo :: String -> String -> Bool -> Nilad
makeSystemInfo os arch js = Nilad (Just $ do
  scope <- createRef $ Scope [ ("os", (VariableConstant, vector $ Character <$> os))
                             , ("arch", (VariableConstant, vector $ Character <$> arch))
                             , ("js", (VariableConstant, scalar $ boolToScalar js))] [] [] [] Nothing
  ctx <- get
  pure $ scalar $ Struct $ ctx{ contextScope = scope } ) Nothing (G.quad : "systemInfo") Nothing

Timestamp

While ⎕unix returns the current Unix timestamp, ⎕ts returns a more user-friendly value: a vector of year, month, day, hours, minutes, seconds and milliseconds.

fixedToFractional :: (Fractional b, HasResolution r) => Fixed r -> b
fixedToFractional f@(MkFixed v) = fromIntegral v / fromIntegral (resolution f)

ts = Nilad (Just $ do
  utc <- liftToSt $ posixSecondsToUTCTime <$> getPOSIXTime
  let (YearMonthDay y m d) = utctDay utc
  let (TimeOfDay h min s') = timeToTimeOfDay $ utctDayTime utc
  let s = floor $ fixedToFractional s'
  let ms = round $ fracPart (fixedToFractional s') * 1000
  pure $ vector [Number $ fromIntegral y, Number $ fromIntegral m, Number $ fromIntegral d, Number $ fromIntegral h, Number $ fromIntegral min, Number $ fromIntegral s, Number $ fromIntegral ms]) Nothing (G.quad : "ts") Nothing

Decode

Decode and Base 2 Decode ⊥ are two related functions (the latter is the former with a default argument) which convert a number in base representation back to its original number. In the most general form, the left argument is a mixed base vector which defines the value of each position in the right "coefficients" vector. Alternatively, the left argument can be a scalar and it is replicated for each element of the right vector.

decode :: MonadError Error m => [Complex Double] -> [Complex Double] -> m (Complex Double)
decode ns cs =
  if length ns /= length cs then throwError $ LengthError "Decode arguments must have the same length"
  else pure $ sum $ zipWith (*) (Prelude.reverse $ scanl1 (*) (init $ 1 : Prelude.reverse ns)) cs

decode' :: MonadError Error m => Array -> Array -> m Array
decode' = (\ns cs -> do
  let err = DomainError "Decode arguments must be number arrays"
  cs' <- asVector err cs >>= mapM (asNumber err)
  ns' <- case asScalar err ns of
    Right x -> Prelude.replicate (length cs') <$> asNumber err x
    Left _ -> asVector err ns >>= mapM (asNumber err)
  scalar . Number <$> decode ns' cs') `atRank2` (1, 1)

decodeBase2 :: MonadError Error m => Array -> m Array
decodeBase2 = decode' (scalar $ Number 2)

Encode

Encode and Base 2 Encode ⊤ are, in some sense, the inverse function to Decode. Encoding where the left argument is a vector does the opposite operation of decoding with that mixed base.

encode :: MonadError Error m => [Complex Double] -> Complex Double -> m [Complex Double]
encode [] _ = pure []
encode (bs :> b) n = do
  let rem = if b == 0 then n else b `complexRemainder` n
  let div = if b == 0 then 0 else complexFloor $ n / b
  (`snoc` rem) <$> encode bs div

Encode where the left argument is a scalar is more complex. I'll quote the documentation:

If x [the left argument] is scalar, operates on vectors of y [the right argument], x must have magnitude greater than 1 and the following recursive procedure is performed:

  • if y=0, then r is ⟨⟩
  • let rem be x|y and div be ⌊y÷x
  • let rem1 be x|div and div1 be ⌊div÷x
  • if rem=rem1 and div=div1 then r is y
  • otherwise r is rem⍪⍨x⊤div

In other words, the same number is used for the repeated modulo and floor-division until two results are equal, which means we have reached a point where we would loop.

encodeScalar :: MonadError Error m => Complex Double -> Complex Double -> m [Complex Double]
encodeScalar b _ | Cx.magnitude b <= 1 = throwError $ DomainError "Scalar encode left argument must be greater than 1 in magnitude"
encodeScalar _ n | Number n == Number 0 = pure []
encodeScalar b n = do
  let rem = b `complexRemainder` n
  let div = complexFloor $ n / b
  let rem1 = b `complexRemainder` div
  let div1 = complexFloor $ div / b
  if rem == rem1 && div == div1 then pure [n]
  else (`snoc` rem) <$> encodeScalar b div

encode' :: MonadError Error m => Array -> Array -> m Array
encode' = (\b n -> do
  let err = DomainError "Encode arguments must be number arrays"
  n' <- asScalar err n >>= asNumber err
  case asScalar err b of
    Right b' -> vector . fmap Number . (\xs -> if null xs then [0] else xs) <$> (asNumber err b' >>= flip encodeScalar n')
    Left _ -> vector . fmap Number <$> (asVector err b >>= mapM (asNumber err) >>= flip encode n')) `atRank2` (1, 0)

encodeBase2 :: MonadError Error m => Array -> m Array
encodeBase2 = encode' (scalar $ Number 2)

Identity Modifiers

There are three "identity modifiers" that are taken from J and are very useful in modifier trains: Lev ⫣, Dex ⊩ and Ident ⫤. Respectively, these are a conjunction returning the left operand, a conjunction returning the right operand, an adverb returning the (only) operand.

ident = Adverb
  { adverbRepr = [G.ident]
  , adverbContext = Nothing
  , adverbOnArray = Just $ \n -> pure $ Function (Just $ F.constant1 n) (Just $ F.constant2 n) (makeAdverbRepr (show n) G.ident) Nothing
  , adverbOnFunction = Just $ \f -> pure $ Function (Just $ callMonad f) (Just $ callDyad f) (makeAdverbRepr (show f) G.ident) Nothing }

lev = Conjunction
  { conjRepr = [G.lev]
  , conjContext = Nothing
  , conjOnArrayArray = Just $ \n m -> pure $ Function (Just $ F.constant1 n) (Just $ F.constant2 n) (makeConjRepr (show n) G.lev (show m)) Nothing
  , conjOnArrayFunction = Just $ \n g -> pure $ Function (Just $ F.constant1 n) (Just $ F.constant2 n) (makeConjRepr (show n) G.lev (show g)) Nothing
  , conjOnFunctionArray = Just $ \f m -> pure $ Function (Just $ callMonad f) (Just $ callDyad f) (makeConjRepr (show f) G.lev (show m)) Nothing
  , conjOnFunctionFunction = Just $ \f g -> pure $ Function (Just $ callMonad f) (Just $ callDyad f) (makeConjRepr (show f) G.lev (show g)) Nothing }
dex = Conjunction
  { conjRepr = [G.dex]
  , conjContext = Nothing
  , conjOnArrayArray = Just $ \n m -> pure $ Function (Just $ F.constant1 m) (Just $ F.constant2 m) (makeConjRepr (show n) G.dex (show m)) Nothing
  , conjOnArrayFunction = Just $ \n g -> pure $ Function (Just $ callMonad g) (Just $ callDyad g) (makeConjRepr (show n) G.dex (show g)) Nothing
  , conjOnFunctionArray = Just $ \f m -> pure $ Function (Just $ F.constant1 m) (Just $ F.constant2 m) (makeConjRepr (show f) G.dex (show m)) Nothing
  , conjOnFunctionFunction = Just $ \f g -> pure $ Function (Just $ callMonad g) (Just $ callDyad g) (makeConjRepr (show f) G.dex (show g)) Nothing }

Fold and Fold Back

Fold is like seeded Reduce, i.e. you pass an initial value.

fold :: MonadError Error m => (a -> a -> m a) -> a -> [a] -> m a
fold = foldlM

fold' :: MonadError Error m => (Array -> Array -> m Array) -> Array -> Array -> m Array
fold' f s xs = fold f s $ majorCells xs

foldBack :: MonadError Error m => (a -> a -> m a) -> a -> [a] -> m a
foldBack = foldrM

foldBack' :: MonadError Error m => (Array -> Array -> m Array) -> Array -> Array -> m Array
foldBack' f s xs = foldBack f s $ majorCells xs

Search Functions

Search functions all support "major cell search". This is breaking backwards compatibility with other APLs for Element Of. Thanks to @dzaima for helping me out with this definition.

searchFunction :: MonadError Error m => (Array -> [Array] -> m Array) -> Array -> Array -> m Array
searchFunction f ns hs = let cutRank = if arrayRank hs == 0 then 0 else arrayRank hs - 1
  in if arrayRank ns < cutRank then throwError $ DomainError "Search function neelde must have rank at least equal to the rank of the major cells of the haystack"
  else do
    let hc = majorCells hs
    nc <- atRank1 enclose' (toInteger cutRank) ns
    onScalars1 (\n -> do
      n' <- first n
      f n' hc) nc

elementOf :: MonadError Error m => Array -> Array -> m Array
elementOf = searchFunction $ pure .: scalar .: boolToScalar .: elem

count :: MonadError Error m => Array -> Array -> m Array
count = searchFunction $ pure .: scalar .: Number .: (:+ 0) .: countEqual

indexOf :: MonadError Error m => Array -> Array -> m Array
indexOf = flip $ searchFunction $ pure .: scalar .: Number .: (:+ 0) .: (\n hs -> case n `genericElemIndex` hs of
  Just x -> x + 1
  Nothing -> genericLength hs + 1)

Interval Index

While Interval Index is also a search function, it's a bit more complex and might benefit from a description. The implementation makes pairs of lower and upper bounds for each section marked by the left argument and then finds the rightmost one where the right argument fits.

intervalIndex :: MonadError Error m => Array -> Array -> m Array
intervalIndex hs' ns =
  if Prelude.not $ sorted $ majorCells hs' then throwError $ DomainError "Interval index left argument must be sorted"
  else (searchFunction $ pure .: scalar .: Number .: (:+ 0) .: (\n hs -> do
    let lowers = Nothing : fmap Just hs
    let uppers = fmap Just hs :> Nothing
    let bounds = Prelude.reverse $ zipWith3 (\l u i -> ((l, u), i)) lowers uppers [0..genericLength hs]
    fromMaybe 0 $ fmap snd $ flip find bounds $ \case
      ((Just lower, Just upper), _) | lower <= n && n < upper -> True
      ((Just lower, Nothing), _) | lower <= n -> True
      ((Nothing, Just upper), _) | n < upper -> True
      _ -> False)) ns hs'