TinyAPL part 1: Introduction & Arrays

module TinyAPL where

import Data.Complex

data ScalarValue
  = Number (Complex Double)
  | Character Char
  | Box Array

import GHC.Natural

-- length (arrayContents arr) == product (arrayShape arr)
data Array = Array {
  arrayShape :: [Natural],
  arrayContents :: [ScalarValue]
}

import Data.List (genericLength, genericTake, singleton)

scalar :: ScalarValue -> Array
scalar x = Array [] [x]

vector :: [ScalarValue] -> Array
vector xs = Array [length xs] xs

arrayOf :: [Natural] -> [ScalarValue] -> Maybe Array
arrayOf sh cs
  | product sh == genericLength cs = Just $ Array sh cs
  | otherwise = Nothing

arrayReshaped :: [Natural] -> [ScalarValue] -> Array
arrayReshaped sh cs = Array sh $ take (product sh) $ cycle cs

comparisonTolerance = 1e-14

realEqual a b = abs (a - b) <= comparisonTolerance * (abs a `max` abs b)
complexEqual a b = magnitude (a - b) <= comparisonTolerance * (magnitude a `max` magnitude b)

isReal (_ :+ b) = realEqual 0 b

instance Eq ScalarValue where
  (Number a) == (Number b)
    | isReal a && isReal b = realPart a `realEqual` realPart b
    | otherwise = a `complexEqual` b
  (Character a) == (Character b) = a == b
  (Box as) == (Box bs) = as == bs
  _ == _ = False -- different types are never equal

instance Ord ScalarValue where
  {-
  Order is as such:
    * numbers ordered lexically (real part then imaginary part)
    * characters ordeded by codepoint
    * boxes ordered by contents
  -}
  (Number (ar :+ ai)) `compare` (Number (br :+ bi))
    | ar `realEqual` br && ai `realEqual` bi = EQ
    | ar `realEqual` br = ai `compare` bi
    | otherwise = ar `compare` br
  (Character a) `compare` (Character b) = a `compare` b
  (Box as) `compare` (Box bs) = as `compare` bs
  (Number _) `compare` _ = LT -- numbers are less than any other type
  (Character _) `compare` (Number _) = GT
  (Character _) `compare` _ = LT -- characters are less than any type but numbers
  (Box _) `compare` _ = GT -- boxes are larger than any other type

instance Eq Array where
  (Array ash as) == (Array bsh bs) = (ash, as) == (bsh, bs)

instance Ord Array where
  -- Arrays are ordered by shape and then by contents
  (Array ash as) `compare` (Array bsh bs)
    | ash == bsh = as `compare` bs
    | otherwise = as `compare` bs

module TinyAPL.Glyphs where
import Data.Char (chr)

negative = chr 0xaf
ravel = ','
rho = chr 0x2374
imaginaryI = chr 0x1d456
imaginaryJ = chr 0x1d457

import qualified TinyAPL.Glyphs as G

showNatural = show
showInteger x
  | x < 0 = G.negative : showNatural (abs x)
  | otherwise = showNatural x
showFrac x
  | x `realEqual` fromInteger (floor x) = showInteger $ fromInteger $ floor x
  | 0 < x && x < 1 = tail $ show x
  | (-1 < x) && x < 0 = G.negative : tail (show x)
  | otherwise = showInteger x
showComplex (a :+ b)
  | b `realEqual` 0 = showFrac a
  | a `realEqual` 0 = showFrac a : G.imaginaryI
  | otherwise = showReal a ++ (G.imaginaryJ : showReal b)

instance Show ScalarValue where
  show (Character ch) = [ch]
  show (Box xs) = "[box " ++ show xs ++ "]"
  show (Number x) = showComplex x

instance Show Array where
  show (Array sh cs) = "{array with " ++ [G.rho] ++ " = " ++ unwords (map show sh) ++ " and " ++ [G.ravel] ++ " = " ++ show cs ++ "}"

import GHC.Stack (HasCallStack)

data Error
  = DomainError String
  | LengthError String
  | RankError String
  | NYIError String
  deriving (Show)

type Result a = Either Error a

unerror :: HasCallStack => Result a -> a
unerror (Right x) = x
unerror (Left e) = error $ show e

err :: Error -> Result a
err = Left

asNumber :: Error -> ScalarValue -> Result (Complex Double)
asNumber _ (Number x) = pure x
asNumber e _ = err e

asReal :: Error -> Complex Double -> Result Double
asReal e x
  | isReal x = pure $ realPart x
  | otherwise = err e

asInt :: Integral n => Error -> Complex Double -> Result n
asInt e x = do
  real <- asReal e x
  if real `realsEqual` fromInteger (floor real) then pure $ floor real else err e

asNat :: Error -> Complex Double -> Result Natural
asNat e x = do
  int <- asInt e x
  if int >= 0 then pure $ toEnum int else err e

isScalar :: Array -> Boolean
isScalar (Array _ [_]) = True
isScalar _ = False

asScalar :: Error -> Array -> Result ScalarValue
asScalar _ (Array _ [x]) = pure x
asScalar e _ = err e

import Control.Monad (zipWithM)

scalarDyad ::
  (ScalarValue -> ScalarValue -> Errors ScalarValue)
  -> Array
  -> Array
  -> Result Array
scalarDyad f a b = 
  if isScalar a && isScalar b then do
    a' <- asScalar a
    b' <- asScalar b
    scalar . singleton <$> f' a' b'
  else if isScalar a then do
    a' <- asScalar a
    let (Array bsh bs) = b
    Array bsh <$> mapM (a' `f'`) bs
  else if isScalar b then do
    b' <- asScalar b
    let (Array ash as) = a
    Array ash <$> mapM (`f'` b') as
  else if arrayShape a == arrayShape b then do
    let (Array sh as) = a
    let (Array _ bs) = b
    Array sh <$> zipWithM f' as bs
  else err $ DomainError "Mismatched left and right argument shapes"
  where
  f' (Box as) (Box bs) = Box <$> scalarDyad f as bs
  f' (Box as) b = Box <$> scalarDyad f as $ scalar b
  f' a (Box bs) = Box <$> scalarDyad f (scalar a) bs
  f' a b = f a b

{-# LANGUAGE LambdaCase #-}

monadN2N f = scalarMonad f' where
  f' x = do
    x' <- asNumber x
    Number <$> f x'

monadN2N' f = monadN2N (pure . f)

dyadNN2N f = scalarDyad f' where
  f' a b = do
    a' <- asNumber a
    b' <- asNumber b
    Number <$> f a' b'

dyadNN2N' f = dyadNN2N (pure .: f)

instance Num Array where
  (+) = unerror .: dyadNN2N' (+)
  (-) = unerror .: dyadNN2N' (-)
  (*) = unerror .: dyadNN2N' (*)
  abs = unerror . monadN2N' abs
  signum = unerror . monadN2N' signum
  negate = unerror . monadN2N' negate
  fromInteger = scalar . Number . fromInteger

instance Fractional Array where
  recip = unerror . monadN2N (\case
    0 -> err $ DomainError "Divide by zero"
    x -> pure $ recip x)
  (/) = unerror . dyadNN2N ((\case
    (0, 0) -> pure 1
    (_, 0) -> err $ DomainError "Divide by zero"
    (a, b) -> pure $ x / y
  ) .* (,))
  fromRational = scalar . Number . fromRational

instance Floating Array where
  pi = scalar $ Number pi
  exp = unerror . monadN2N' exp
  log = unerror . monadN2N (\case
    0 -> err $ DomainError "Logarithm of zero"
    x -> pure $ log x)
  sin = unerror . monadN2N' sin
  cos = unerror . monadN2N' cos
  tan = unerror . monadN2N' tan
  asin = unerror . monadN2N' asin
  acos = unerror . monadN2N' acos
  atan = unerror . monadN2N' atan
  sinh = unerror . monadN2N' sinh
  cosh = unerror . monadN2N' cosh
  tanh = unerror . monadN2N' tanh
  asinh = unerror . monadN2N' asinh
  acosh = unerror . monadN2N' acosh
  atanh = unerror . monadN2N' atanh