{- ORMOLU_DISABLE -}
-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
-- Copyright (C) 2016, Julia Longtin (julial@turinglace.com)
-- Released under the GNU AGPLV3+, see LICENSE

-- Allow us to use string literals to represent Text.
{-# LANGUAGE OverloadedStrings #-}

-- Allow the use of \case
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}

module Graphics.Implicit.ExtOpenScad.Default (defaultObjects) where

-- be explicit about where we pull things in from.
import Prelude (Bool(True, False), Maybe(Just, Nothing), ($), (<>), (<$>), fmap, pi, sin, cos, tan, asin, acos, atan, sinh, cosh, tanh, abs, signum, fromInteger, (.), floor, ceiling, round, exp, log, sqrt, max, min, atan2, (**), flip, (<), (>), (<=), (>=), (==), (/=), (&&), (||), not, show, foldl, (*), (/), mod, (+), zipWith, (-), otherwise, id, foldMap, fromIntegral, IO, pure, Int, isNaN, negate, RealFloat, Ord)
import qualified Prelude as P (length)

import Graphics.Implicit.Definitions (ℝ, ℕ)

import Graphics.Implicit.ExtOpenScad.Definitions (VarLookup(VarLookup), OVal(OBool, OList, ONum, OString, OUndefined, OError, OFunc, OVargsModule, OIO), Symbol(Symbol), StateC, StatementI, SourcePosition, MessageType(TextOut, Warning), ScadOpts(ScadOpts))

import Graphics.Implicit.ExtOpenScad.Util.OVal (toOObj, oTypeStr)

import Graphics.Implicit.ExtOpenScad.Primitives (primitiveModules)

import Graphics.Implicit.ExtOpenScad.Util.StateC (scadOptions, modifyVarLookup, addMessage)

import Data.Int (Int64)

import Data.Map (Map, fromList, insert)

import Data.List (genericIndex, genericLength, find, foldl')

import Data.Foldable (for_, foldr)

import qualified Data.Text.Lazy as TL (index)

import Data.Text.Lazy (Text, intercalate, unpack, pack, length, singleton)
import Control.Monad (replicateM)
import System.Random (randomRIO)
import Data.Maybe (maybe)
import Data.Tuple (snd)
import Linear.Matrix ((!*!), (*!), (!*))
import Graphics.Implicit.MathUtil (infty)

clamp :: Ord a => (a, a) -> a -> a
clamp :: forall a. Ord a => (a, a) -> a -> a
clamp (a
lower, a
upper) a
a = forall a. Ord a => a -> a -> a
min a
upper (forall a. Ord a => a -> a -> a
max a
lower a
a)

defaultObjects :: Bool -> VarLookup
defaultObjects :: Bool -> VarLookup
defaultObjects Bool
withCSG = Map Symbol OVal -> VarLookup
VarLookup forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
fromList forall a b. (a -> b) -> a -> b
$
    [(Symbol, OVal)]
defaultConstants
    forall a. Semigroup a => a -> a -> a
<> [(Symbol, OVal)]
defaultFunctions
    forall a. Semigroup a => a -> a -> a
<> [(Symbol, OVal)]
defaultFunctions2
    forall a. Semigroup a => a -> a -> a
<> [(Symbol, OVal)]
defaultFunctionsSpecial
    forall a. Semigroup a => a -> a -> a
<> [(Symbol, OVal)]
defaultPolymorphicFunctions
    forall a. Semigroup a => a -> a -> a
<> (if Bool
withCSG then [(Symbol, OVal)]
primitiveModules else [])
    forall a. Semigroup a => a -> a -> a
<> [(Symbol, OVal)]
varArgModules

defaultConstants :: [(Symbol, OVal)]
defaultConstants :: [(Symbol, OVal)]
defaultConstants = (\(Symbol
a,ℝ
b) -> (Symbol
a, forall a. OTypeMirror a => a -> OVal
toOObj (ℝ
b :: ℝ))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    [(Text -> Symbol
Symbol Text
"pi", forall a. Floating a => a
pi),
     (Text -> Symbol
Symbol Text
"PI", forall a. Floating a => a
pi)]

-- Values and functions for dealing with NaNs and Infinities.
minimumValue :: ℝ
minimumValue :: ℝ
minimumValue = -ℝ
1e100
maximumValue :: ℝ
maximumValue :: ℝ
maximumValue = ℝ
1e100
nanNegInf :: RealFloat a => a -> a
nanNegInf :: forall a. RealFloat a => a -> a
nanNegInf a
x = if forall a. RealFloat a => a -> Bool
isNaN a
x then -forall t. Fractional t => t
infty else a
x
signedNaNInf :: RealFloat a => a -> a -> a
signedNaNInf :: forall a. RealFloat a => a -> a -> a
signedNaNInf a
x a
y = if forall a. RealFloat a => a -> Bool
isNaN a
y then forall a. Num a => a -> a
signum a
x forall a. Num a => a -> a -> a
* forall t. Fractional t => t
infty else a
y

defaultFunctions :: [(Symbol, OVal)]
defaultFunctions :: [(Symbol, OVal)]
defaultFunctions = (\(Symbol
a,ℝ -> ℝ
b) -> (Symbol
a, forall a. OTypeMirror a => a -> OVal
toOObj ( ℝ -> ℝ
b :: ℝ -> ℝ))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    [
        (Text -> Symbol
Symbol Text
"sin",   forall a. Floating a => a -> a
sin),
        (Text -> Symbol
Symbol Text
"cos",   forall a. Floating a => a -> a
cos),
        (Text -> Symbol
Symbol Text
"tan",   forall a. Floating a => a -> a
tan),
        -- If the value is NaN, set it to the signed infinity of the input
        -- and then clamp the values so that infinity doesn't propagate.
        (Text -> Symbol
Symbol Text
"asin",  \ℝ
x -> forall a. Ord a => (a, a) -> a -> a
clamp (ℝ
minimumValue, ℝ
maximumValue) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RealFloat a => a -> a -> a
signedNaNInf ℝ
x forall a b. (a -> b) -> a -> b
$ forall a. Floating a => a -> a
asin ℝ
x),
        -- same as asin, but we need to invert the input sign when clamping
        (Text -> Symbol
Symbol Text
"acos",  \ℝ
x -> forall a. Ord a => (a, a) -> a -> a
clamp (ℝ
minimumValue, ℝ
maximumValue) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RealFloat a => a -> a -> a
signedNaNInf (forall a. Num a => a -> a
negate ℝ
x) forall a b. (a -> b) -> a -> b
$ forall a. Floating a => a -> a
acos ℝ
x),
        (Text -> Symbol
Symbol Text
"atan",  forall a. Floating a => a -> a
atan),
        (Text -> Symbol
Symbol Text
"sinh",  forall a. Floating a => a -> a
sinh),
        (Text -> Symbol
Symbol Text
"cosh",  forall a. Floating a => a -> a
cosh),
        (Text -> Symbol
Symbol Text
"tanh",  forall a. Floating a => a -> a
tanh),
        (Text -> Symbol
Symbol Text
"abs",   forall a. Num a => a -> a
abs),
        (Text -> Symbol
Symbol Text
"sign",  forall a. Num a => a -> a
signum),
        (Text -> Symbol
Symbol Text
"floor", forall a. Num a => Integer -> a
fromInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
floor ),
        (Text -> Symbol
Symbol Text
"ceil",  forall a. Num a => Integer -> a
fromInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
ceiling ),
        (Text -> Symbol
Symbol Text
"round", forall a. Num a => Integer -> a
fromInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
round ),
        (Text -> Symbol
Symbol Text
"exp",   forall a. Floating a => a -> a
exp),
        -- Log is undefined for negative values, so we are taking those NaNs
        -- and -Infinity values and clamping them to a very negative, but
        -- finite, value.
        (Text -> Symbol
Symbol Text
"ln",    forall a. Ord a => (a, a) -> a -> a
clamp (ℝ
minimumValue, forall t. Fractional t => t
infty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RealFloat a => a -> a
nanNegInf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Floating a => a -> a
log),
        (Text -> Symbol
Symbol Text
"log",   forall a. Ord a => (a, a) -> a -> a
clamp (ℝ
minimumValue, forall t. Fractional t => t
infty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RealFloat a => a -> a
nanNegInf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Floating a => a -> a
log),
        (Text -> Symbol
Symbol Text
"sign",  forall a. Num a => a -> a
signum),
        -- same as log, but clamping to 0 rather than a very large negative value
        (Text -> Symbol
Symbol Text
"sqrt",  forall a. Ord a => (a, a) -> a -> a
clamp (ℝ
0, forall t. Fractional t => t
infty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RealFloat a => a -> a
nanNegInf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Floating a => a -> a
sqrt)
    ]

defaultFunctions2 :: [(Symbol, OVal)]
defaultFunctions2 :: [(Symbol, OVal)]
defaultFunctions2 = (\(Symbol
a,ℝ -> ℝ -> ℝ
b) -> (Symbol
a, forall a. OTypeMirror a => a -> OVal
toOObj (ℝ -> ℝ -> ℝ
b :: ℝ -> ℝ -> ℝ))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    [
        (Text -> Symbol
Symbol Text
"max",   forall a. Ord a => a -> a -> a
max),
        (Text -> Symbol
Symbol Text
"min",   forall a. Ord a => a -> a -> a
min),
        (Text -> Symbol
Symbol Text
"atan2", forall a. RealFloat a => a -> a -> a
atan2),
        (Text -> Symbol
Symbol Text
"pow",   forall a. Floating a => a -> a -> a
(**))
    ]

defaultFunctionsSpecial :: [(Symbol, OVal)]
defaultFunctionsSpecial :: [(Symbol, OVal)]
defaultFunctionsSpecial =
    [
        (Text -> Symbol
Symbol Text
"map", forall a. OTypeMirror a => a -> OVal
toOObj forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip
            (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap :: (OVal -> OVal) -> [OVal] -> [OVal] )
        )
    ]

varArgModules :: [(Symbol, OVal)]
varArgModules :: [(Symbol, OVal)]
varArgModules =
    [
        Text
-> (Symbol
    -> SourcePosition
    -> [(Maybe Symbol, OVal)]
    -> [StatementI]
    -> ([StatementI] -> StateC ())
    -> StateC ())
-> (Symbol, OVal)
modVal Text
"echo" Symbol
-> SourcePosition
-> [(Maybe Symbol, OVal)]
-> [StatementI]
-> ([StatementI] -> StateC ())
-> StateC ()
echo
       ,Text
-> (Symbol
    -> SourcePosition
    -> [(Maybe Symbol, OVal)]
    -> [StatementI]
    -> ([StatementI] -> StateC ())
    -> StateC ())
-> (Symbol, OVal)
modVal Text
"for" Symbol
-> SourcePosition
-> [(Maybe Symbol, OVal)]
-> [StatementI]
-> ([StatementI] -> StateC ())
-> StateC ()
for
       ,Text
-> (Symbol
    -> SourcePosition
    -> [(Maybe Symbol, OVal)]
    -> [StatementI]
    -> ([StatementI] -> StateC ())
    -> StateC ())
-> (Symbol, OVal)
modVal Text
"color" Symbol
-> SourcePosition
-> [(Maybe Symbol, OVal)]
-> [StatementI]
-> ([StatementI] -> StateC ())
-> StateC ()
executeSuite
    ] where
        modVal :: Text
-> (Symbol
    -> SourcePosition
    -> [(Maybe Symbol, OVal)]
    -> [StatementI]
    -> ([StatementI] -> StateC ())
    -> StateC ())
-> (Symbol, OVal)
modVal Text
name Symbol
-> SourcePosition
-> [(Maybe Symbol, OVal)]
-> [StatementI]
-> ([StatementI] -> StateC ())
-> StateC ()
func = (Text -> Symbol
Symbol Text
name, Symbol
-> (Symbol
    -> SourcePosition
    -> [(Maybe Symbol, OVal)]
    -> [StatementI]
    -> ([StatementI] -> StateC ())
    -> StateC ())
-> OVal
OVargsModule (Text -> Symbol
Symbol Text
name) Symbol
-> SourcePosition
-> [(Maybe Symbol, OVal)]
-> [StatementI]
-> ([StatementI] -> StateC ())
-> StateC ()
func)

        -- execute only the child statement, without doing anything else. Useful for unimplemented functions.
        executeSuite :: Symbol -> SourcePosition -> [(Maybe Symbol, OVal)] -> [StatementI] -> ([StatementI] -> StateC ()) -> StateC ()
        executeSuite :: Symbol
-> SourcePosition
-> [(Maybe Symbol, OVal)]
-> [StatementI]
-> ([StatementI] -> StateC ())
-> StateC ()
executeSuite (Symbol Text
name) SourcePosition
pos [(Maybe Symbol, OVal)]
_ [StatementI]
suite [StatementI] -> StateC ()
runSuite = do
            MessageType -> SourcePosition -> Text -> StateC ()
addMessage MessageType
Warning SourcePosition
pos forall a b. (a -> b) -> a -> b
$ Text
"Module " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" not implemented"
            [StatementI] -> StateC ()
runSuite [StatementI]
suite

        echo :: Symbol -> SourcePosition -> [(Maybe Symbol, OVal)] -> [StatementI] -> ([StatementI] -> StateC ()) -> StateC ()
        echo :: Symbol
-> SourcePosition
-> [(Maybe Symbol, OVal)]
-> [StatementI]
-> ([StatementI] -> StateC ())
-> StateC ()
echo Symbol
_ SourcePosition
pos [(Maybe Symbol, OVal)]
args [StatementI]
suite [StatementI] -> StateC ()
runSuite = do
            ScadOpts
scadOpts <- StateC ScadOpts
scadOptions
            let
                text :: [(Maybe Symbol, OVal)] -> Text
                text :: [(Maybe Symbol, OVal)] -> Text
text [(Maybe Symbol, OVal)]
a = Text -> [Text] -> Text
intercalate Text
", " forall a b. (a -> b) -> a -> b
$ (Maybe Symbol, OVal) -> Text
show' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Maybe Symbol, OVal)]
a
                show' :: (Maybe Symbol, OVal) -> Text
                show' :: (Maybe Symbol, OVal) -> Text
show' (Maybe Symbol
Nothing, OVal
arg) = String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show OVal
arg
                show' (Just (Symbol Text
var), OVal
arg) = Text
var forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show OVal
arg)
                showe' :: (Maybe Symbol, OVal) -> Text
                showe' :: (Maybe Symbol, OVal) -> Text
showe' (Maybe Symbol
Nothing, OString Text
arg) = Text
arg
                showe' (Just (Symbol Text
var), OVal
arg) = Text
var forall a. Semigroup a => a -> a -> a
<> Text
" = " forall a. Semigroup a => a -> a -> a
<> (Maybe Symbol, OVal) -> Text
showe' (forall a. Maybe a
Nothing, OVal
arg)
                showe' (Maybe Symbol, OVal)
a = (Maybe Symbol, OVal) -> Text
show' (Maybe Symbol, OVal)
a
                compat :: ScadOpts -> Bool
compat (ScadOpts Bool
compat_flag Bool
_) = Bool
compat_flag
                openScadFormat :: Text
openScadFormat = Text
"ECHO: " forall a. Semigroup a => a -> a -> a
<> [(Maybe Symbol, OVal)] -> Text
text [(Maybe Symbol, OVal)]
args
                extopenscadFormat :: Text
extopenscadFormat = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe Symbol, OVal) -> Text
showe' [(Maybe Symbol, OVal)]
args
                formattedMessage :: Text
formattedMessage = if ScadOpts -> Bool
compat ScadOpts
scadOpts then Text
openScadFormat else Text
extopenscadFormat
            MessageType -> SourcePosition -> Text -> StateC ()
addMessage MessageType
TextOut SourcePosition
pos Text
formattedMessage
            [StatementI] -> StateC ()
runSuite [StatementI]
suite

        for :: Symbol -> SourcePosition -> [(Maybe Symbol, OVal)] -> [StatementI] -> ([StatementI] -> StateC ()) -> StateC ()
        for :: Symbol
-> SourcePosition
-> [(Maybe Symbol, OVal)]
-> [StatementI]
-> ([StatementI] -> StateC ())
-> StateC ()
for Symbol
_ SourcePosition
_ [(Maybe Symbol, OVal)]
args [StatementI]
suite [StatementI] -> StateC ()
runSuite =
            forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([(Maybe Symbol, OVal)] -> [VarLookup -> VarLookup]
iterator [(Maybe Symbol, OVal)]
args) forall a b. (a -> b) -> a -> b
$ \VarLookup -> VarLookup
iter -> do
                (VarLookup -> VarLookup) -> StateC ()
modifyVarLookup VarLookup -> VarLookup
iter
                [StatementI] -> StateC ()
runSuite [StatementI]
suite
          where
            -- convert a list of arguments into a list of functions to transform the VarLookup with new bindings for each possible iteration.
            iterator :: [(Maybe Symbol, OVal)] -> [VarLookup -> VarLookup]
            iterator :: [(Maybe Symbol, OVal)] -> [VarLookup -> VarLookup]
iterator [] = [forall a. a -> a
id]
            iterator ((Maybe Symbol
Nothing, OVal
_):[(Maybe Symbol, OVal)]
iterators) = [(Maybe Symbol, OVal)] -> [VarLookup -> VarLookup]
iterator [(Maybe Symbol, OVal)]
iterators
            iterator ((Just Symbol
var, OVal
vals):[(Maybe Symbol, OVal)]
iterators) = [VarLookup -> VarLookup
outer forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Symbol OVal -> Map Symbol OVal) -> VarLookup -> VarLookup
varify Map Symbol OVal -> Map Symbol OVal
inner | Map Symbol OVal -> Map Symbol OVal
inner <- forall k a. Ord k => k -> a -> Map k a -> Map k a
insert Symbol
var forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OVal -> [OVal]
valsList OVal
vals, VarLookup -> VarLookup
outer <- [(Maybe Symbol, OVal)] -> [VarLookup -> VarLookup]
iterator [(Maybe Symbol, OVal)]
iterators]
            -- convert the loop iterator variable's expression value to a list (possibly of one value)
            valsList :: OVal -> [OVal]
            valsList :: OVal -> [OVal]
valsList v :: OVal
v@(OBool Bool
_) = [OVal
v]
            valsList v :: OVal
v@(ONum ℝ
_) = [OVal
v]
            valsList v :: OVal
v@(OString Text
_) = [OVal
v]
            valsList (OList [OVal]
vs) = [OVal]
vs
            valsList OVal
_ = []
            -- promote a result into a VarLookup
            varify :: (Map Symbol OVal -> Map Symbol OVal) -> VarLookup -> VarLookup
            varify :: (Map Symbol OVal -> Map Symbol OVal) -> VarLookup -> VarLookup
varify Map Symbol OVal -> Map Symbol OVal
f (VarLookup Map Symbol OVal
v) = Map Symbol OVal -> VarLookup
VarLookup forall a b. (a -> b) -> a -> b
$ Map Symbol OVal -> Map Symbol OVal
f Map Symbol OVal
v

-- | more complicated ones:
defaultPolymorphicFunctions :: [(Symbol, OVal)]
defaultPolymorphicFunctions :: [(Symbol, OVal)]
defaultPolymorphicFunctions =
    [
        (Text -> Symbol
Symbol Text
"+", forall a. OTypeMirror a => a -> OVal
toOObj OVal -> OVal -> OVal
add),
        (Text -> Symbol
Symbol Text
"sum", OVal
sumtotal),
        (Text -> Symbol
Symbol Text
"*", forall a. OTypeMirror a => a -> OVal
toOObj OVal -> OVal -> OVal
mult),
        (Text -> Symbol
Symbol Text
"prod", OVal
prod),
        (Text -> Symbol
Symbol Text
"/", OVal
divide),
        (Text -> Symbol
Symbol Text
"-", forall a. OTypeMirror a => a -> OVal
toOObj OVal -> OVal -> OVal
sub),
        (Text -> Symbol
Symbol Text
"%", forall a. OTypeMirror a => a -> OVal
toOObj OVal -> OVal -> OVal
omod),
        (Text -> Symbol
Symbol Text
"^", forall a. OTypeMirror a => a -> OVal
toOObj (forall a. Floating a => a -> a -> a
(**) :: ℝ -> ℝ -> ℝ)),
        (Text -> Symbol
Symbol Text
"negate", forall a. OTypeMirror a => a -> OVal
toOObj OVal -> OVal
negatefun),
        (Text -> Symbol
Symbol Text
"index", forall a. OTypeMirror a => a -> OVal
toOObj OVal -> OVal -> OVal
index),
        (Text -> Symbol
Symbol Text
"splice", forall a. OTypeMirror a => a -> OVal
toOObj OVal -> OVal -> OVal -> OVal
osplice),
        (Text -> Symbol
Symbol Text
"<", forall a. OTypeMirror a => a -> OVal
toOObj  (forall a. Ord a => a -> a -> Bool
(<) :: ℝ -> ℝ -> Bool) ),
        (Text -> Symbol
Symbol Text
">", forall a. OTypeMirror a => a -> OVal
toOObj  (forall a. Ord a => a -> a -> Bool
(>) :: ℝ -> ℝ -> Bool) ),
        (Text -> Symbol
Symbol Text
">=", forall a. OTypeMirror a => a -> OVal
toOObj (forall a. Ord a => a -> a -> Bool
(>=) :: ℝ -> ℝ -> Bool) ),
        (Text -> Symbol
Symbol Text
"<=", forall a. OTypeMirror a => a -> OVal
toOObj (forall a. Ord a => a -> a -> Bool
(<=) :: ℝ -> ℝ -> Bool) ),
        (Text -> Symbol
Symbol Text
"==", forall a. OTypeMirror a => a -> OVal
toOObj (forall a. Eq a => a -> a -> Bool
(==) :: OVal -> OVal -> Bool) ),
        (Text -> Symbol
Symbol Text
"!=", forall a. OTypeMirror a => a -> OVal
toOObj (forall a. Eq a => a -> a -> Bool
(/=) :: OVal -> OVal -> Bool) ),
        (Text -> Symbol
Symbol Text
"?", forall a. OTypeMirror a => a -> OVal
toOObj ( forall t. Bool -> t -> t -> t
ternary :: Bool -> OVal -> OVal -> OVal) ),
        (Text -> Symbol
Symbol Text
"&&", forall a. OTypeMirror a => a -> OVal
toOObj Bool -> Bool -> Bool
(&&) ),
        (Text -> Symbol
Symbol Text
"||", forall a. OTypeMirror a => a -> OVal
toOObj Bool -> Bool -> Bool
(||) ),
        (Text -> Symbol
Symbol Text
"!", forall a. OTypeMirror a => a -> OVal
toOObj Bool -> Bool
not ),
        (Text -> Symbol
Symbol Text
"list_gen", forall a. OTypeMirror a => a -> OVal
toOObj [ℝ] -> Maybe [ℝ]
list_gen),
        (Text -> Symbol
Symbol Text
"<>", OVal
concatenate),
        (Text -> Symbol
Symbol Text
"len", forall a. OTypeMirror a => a -> OVal
toOObj OVal -> OVal
olength),
        (Text -> Symbol
Symbol Text
"str", forall a. OTypeMirror a => a -> OVal
toOObj (String -> Text
packforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> String
show :: OVal -> Text)),
        (Text -> Symbol
Symbol Text
"rands", forall a. OTypeMirror a => a -> OVal
toOObj ℝ -> ℝ -> ℝ -> IO OVal
rands),
        (Text -> Symbol
Symbol Text
"lookup", forall a. OTypeMirror a => a -> OVal
toOObj ℝ -> [(ℝ, ℝ)] -> OVal
lookup)
    ] where

        -- Some key functions are written as OVals in optimizations attempts

        -- Lookup a value from the given table, or linearly interpolate a value from
        -- the nearest entries. Lookups for keys that fall outside the bounds of the
        -- table will be given the value of the nearest table entry.
        -- TODO, a binary tree would be faster for large tables, but I'm not bothering
        -- until we have a good reason to do so, i.e. we see a need for it.
        lookup :: ℝ -> [(ℝ, ℝ)] -> OVal
        lookup :: ℝ -> [(ℝ, ℝ)] -> OVal
lookup ℝ
key [(ℝ, ℝ)]
table =
            let
                -- Find the next lower value, and the next upper value from key
                search :: (ℝ -> ℝ -> Bool) -> (ℝ -> ℝ -> Bool) -> Maybe (ℝ, ℝ)
search ℝ -> ℝ -> Bool
op ℝ -> ℝ -> Bool
op' = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                    (\t :: (ℝ, ℝ)
t@(ℝ
k, ℝ
_) -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                        ( if ℝ
k ℝ -> ℝ -> Bool
`op` ℝ
key
                          then forall (f :: * -> *) a. Applicative f => a -> f a
pure (ℝ, ℝ)
t
                          else forall a. Maybe a
Nothing
                        )
                        forall a b. (a -> b) -> a -> b
$ \t' :: (ℝ, ℝ)
t'@(ℝ
k', ℝ
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
                            if ℝ
k ℝ -> ℝ -> Bool
`op'` ℝ
k' Bool -> Bool -> Bool
&& ℝ
k ℝ -> ℝ -> Bool
`op` ℝ
key
                            then (ℝ, ℝ)
t
                            else (ℝ, ℝ)
t'
                    )
                    forall a. Maybe a
Nothing
                    [(ℝ, ℝ)]
table
                lower :: Maybe (ℝ, ℝ)
lower = (ℝ -> ℝ -> Bool) -> (ℝ -> ℝ -> Bool) -> Maybe (ℝ, ℝ)
search forall a. Ord a => a -> a -> Bool
(<) forall a. Ord a => a -> a -> Bool
(>)
                upper :: Maybe (ℝ, ℝ)
upper = (ℝ -> ℝ -> Bool) -> (ℝ -> ℝ -> Bool) -> Maybe (ℝ, ℝ)
search forall a. Ord a => a -> a -> Bool
(>) forall a. Ord a => a -> a -> Bool
(<)
                -- Interpolate linearly
                -- Take the extremes if the key is out of bounds.
                -- Undefined for empty tables, as the docs don't say what it should be.
                -- https://en.wikibooks.org/wiki/OpenSCAD_User_Manual/Mathematical_Functions#lookup
                interpolated :: OVal
interpolated = case (Maybe (ℝ, ℝ)
lower, Maybe (ℝ, ℝ)
upper) of
                    (Just (ℝ
lk, ℝ
lv), Just (ℝ
uk, ℝ
uv)) ->
                        -- calculate the linear slope of the graph
                        let scale :: ℝ
scale = (ℝ
uv forall a. Num a => a -> a -> a
- ℝ
lv) forall a. Fractional a => a -> a -> a
/ (ℝ
uk forall a. Num a => a -> a -> a
- ℝ
lk)
                        -- Use the lower value as the base, and add on the
                        -- required amount of scaling
                        in ℝ -> OVal
ONum forall a b. (a -> b) -> a -> b
$ ℝ
lv forall a. Num a => a -> a -> a
+ ((ℝ
key forall a. Num a => a -> a -> a
- ℝ
lk) forall a. Num a => a -> a -> a
* ℝ
scale)
                    (Maybe (ℝ, ℝ)
Nothing, Just (ℝ
_, ℝ
uv)) -> ℝ -> OVal
ONum ℝ
uv
                    (Just (ℝ
_, ℝ
lv), Maybe (ℝ, ℝ)
Nothing) -> ℝ -> OVal
ONum ℝ
lv
                    (Maybe (ℝ, ℝ)
Nothing, Maybe (ℝ, ℝ)
Nothing)      -> OVal
OUndefined
            in forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                OVal
interpolated
                (ℝ -> OVal
ONum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
                forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(ℝ
k, ℝ
_) -> ℝ
k forall a. Eq a => a -> a -> Bool
== ℝ
key) [(ℝ, ℝ)]
table

        rands :: ℝ -> ℝ -> ℝ -> IO OVal
        rands :: ℝ -> ℝ -> ℝ -> IO OVal
rands ℝ
minR ℝ
maxR ℝ
count = do
            [ℝ]
l <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall a b. (RealFrac a, Integral b) => a -> b
round ℝ
count) forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (ℝ
minR, ℝ
maxR)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. [OVal] -> OVal
OList forall a b. (a -> b) -> a -> b
$ ℝ -> OVal
ONum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ℝ]
l

        prod :: OVal
prod = (OVal -> OVal) -> OVal
OFunc forall a b. (a -> b) -> a -> b
$ \case
            (OList (OVal
y:[OVal]
ys)) -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl OVal -> OVal -> OVal
mult OVal
y [OVal]
ys
            (OList [])     -> ℝ -> OVal
ONum ℝ
1
            (ONum ℝ
a)       -> (OVal -> OVal) -> OVal
OFunc forall a b. (a -> b) -> a -> b
$ \case
                (OList []) -> ℝ -> OVal
ONum ℝ
a
                (OList [OVal]
n)  -> OVal -> OVal -> OVal
mult (ℝ -> OVal
ONum ℝ
a) ([OVal] -> OVal
OList [OVal]
n)
                (ONum ℝ
b)   -> OVal -> OVal -> OVal
mult (ℝ -> OVal
ONum ℝ
a) (ℝ -> OVal
ONum ℝ
b)
                OVal
_          -> Text -> OVal
OError Text
"prod takes only lists or nums"
            OVal
_              -> Text -> OVal
OError Text
"prod takes only lists or nums"

        toNumList :: [OVal] -> Maybe [ℝ]
        toNumList :: [OVal] -> Maybe [ℝ]
toNumList [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        toNumList (ONum ℝ
r:[OVal]
l) = (ℝ
r forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OVal] -> Maybe [ℝ]
toNumList [OVal]
l
        toNumList [OVal]
_ = forall a. Maybe a
Nothing

        -- Given a matrix, ensure that each row is
        -- at least as big as the first row, and
        -- return the dimentions.
        normaliseMatrix :: [[OVal]] -> Maybe ([[ℝ]], Int, Int) -- Matrix, outer length, inner length
        normaliseMatrix :: [[OVal]] -> Maybe ([[ℝ]], Int, Int)
normaliseMatrix [] = forall a. a -> Maybe a
Just ([], Int
0, Int
0)
        normaliseMatrix [[OVal]
a] = (\[ℝ]
a' -> (forall (f :: * -> *) a. Applicative f => a -> f a
pure [ℝ]
a', Int
1, forall (t :: * -> *) a. Foldable t => t a -> Int
P.length [OVal]
a)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OVal] -> Maybe [ℝ]
toNumList [OVal]
a
        -- foldl is used because we need to track the length of the first sub-list throughout
        normaliseMatrix ([OVal]
a:[[OVal]]
as) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Maybe ([[ℝ]], Int, Int) -> [OVal] -> Maybe ([[ℝ]], Int, Int)
go Maybe ([[ℝ]], Int, Int)
base [[OVal]]
as
            where
                base :: Maybe ([[ℝ]], Int, Int)
                base :: Maybe ([[ℝ]], Int, Int)
base = (\[ℝ]
a' -> ([[ℝ]
a'], Int
1, forall (t :: * -> *) a. Foldable t => t a -> Int
P.length [OVal]
a)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OVal] -> Maybe [ℝ]
toNumList [OVal]
a
                go:: Maybe ([[ℝ]], Int, Int) -> [OVal] -> Maybe ([[ℝ]], Int, Int)
                go :: Maybe ([[ℝ]], Int, Int) -> [OVal] -> Maybe ([[ℝ]], Int, Int)
go Maybe ([[ℝ]], Int, Int)
Nothing [OVal]
_ = forall a. Maybe a
Nothing
                go Maybe ([[ℝ]], Int, Int)
x [] = Maybe ([[ℝ]], Int, Int)
x
                go (Just ([[ℝ]]
xs, Int
l, Int
l')) [OVal]
y =
                    if forall (t :: * -> *) a. Foldable t => t a -> Int
P.length [OVal]
y forall a. Ord a => a -> a -> Bool
>= Int
l'
                    then (\[ℝ]
y' -> ([[ℝ]]
xs forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Applicative f => a -> f a
pure [ℝ]
y', Int
l forall a. Num a => a -> a -> a
+ Int
1, Int
l')) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OVal] -> Maybe [ℝ]
toNumList [OVal]
y
                    else forall a. Maybe a
Nothing

        -- scalar
        mult :: OVal -> OVal -> OVal
mult (ONum ℝ
a)  (ONum ℝ
b)  = ℝ -> OVal
ONum  (ℝ
aforall a. Num a => a -> a -> a
*ℝ
b)
        -- vector-number
        mult (ONum ℝ
a)  (OList [OVal]
b) = [OVal] -> OVal
OList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (OVal -> OVal -> OVal
mult (ℝ -> OVal
ONum ℝ
a)) [OVal]
b)
        mult b :: OVal
b@(OList [OVal]
_)  a :: OVal
a@(ONum ℝ
_) = OVal -> OVal -> OVal
mult OVal
a OVal
b
        -- (vector|matrix)-(vector|matrix)
        mult (OList [OVal]
a) (OList [OVal]
b) = case (Maybe [[OVal]]
aList, Maybe [[OVal]]
bList) of
            -- matrix multiplication
            (Just [[OVal]]
a', Just [[OVal]]
b') -> case ([[OVal]] -> Maybe ([[ℝ]], Int, Int)
normaliseMatrix [[OVal]]
a', [[OVal]] -> Maybe ([[ℝ]], Int, Int)
normaliseMatrix [[OVal]]
b') of
                (Just ([[ℝ]]
as, Int
_aOuter, Int
aInner), Just ([[ℝ]]
bs, Int
bOuter, Int
_bInner)) ->
                    if Int
aInner forall a. Eq a => a -> a -> Bool
== Int
bOuter
                    then [OVal] -> OVal
OList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([OVal] -> OVal
OList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ℝ -> OVal
ONum) forall a b. (a -> b) -> a -> b
$ [[ℝ]]
as forall (m :: * -> *) (t :: * -> *) (n :: * -> *) a.
(Functor m, Foldable t, Additive t, Additive n, Num a) =>
m (t a) -> t (n a) -> m (n a)
!*! [[ℝ]]
bs
                    else Text -> OVal
OError Text
"Matrices of * do not have a matching M dimention for NxM and MxP"
                (Maybe ([[ℝ]], Int, Int)
Nothing, Maybe ([[ℝ]], Int, Int)
_) -> Text -> OVal
OError Text
"First matrix of * has rows that are too short."
                (Maybe ([[ℝ]], Int, Int)
_, Maybe ([[ℝ]], Int, Int)
Nothing) -> Text -> OVal
OError Text
"Second matrix of * has rows that are too short."
            -- matrix * vector multiplication
            -- These aren't commutative so we have to do it the hard way
            -- https://en.wikibooks.org/wiki/OpenSCAD_User_Manual/Mathematical_Operators
            (Just [[OVal]]
a', Maybe [[OVal]]
_) -> case [[OVal]] -> Maybe ([[ℝ]], Int, Int)
normaliseMatrix [[OVal]]
a' of
                Just ([[ℝ]]
as, Int
_aOuter, Int
aInner) ->
                    if forall (t :: * -> *) a. Foldable t => t a -> Int
P.length [OVal]
b forall a. Ord a => a -> a -> Bool
>= Int
aInner
                    then
                        forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                            (Text -> OVal
OError Text
"Second vector of * is not a list of numbers.")
                            (\[ℝ]
b' -> [OVal] -> OVal
OList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ℝ -> OVal
ONum forall a b. (a -> b) -> a -> b
$ [[ℝ]]
as forall (m :: * -> *) (r :: * -> *) a.
(Functor m, Foldable r, Additive r, Num a) =>
m (r a) -> r a -> m a
!* [ℝ]
b')
                            forall a b. (a -> b) -> a -> b
$ [OVal] -> Maybe [ℝ]
toNumList [OVal]
b
                    else Text -> OVal
OError Text
"Second vector of * is too short to multiply with the matrix."
                Maybe ([[ℝ]], Int, Int)
_ -> Text -> OVal
OError Text
"First matrix of * has rows that are too short."
            -- vector * matrix multiplication
            (Maybe [[OVal]]
_, Just [[OVal]]
b') -> case [[OVal]] -> Maybe ([[ℝ]], Int, Int)
normaliseMatrix [[OVal]]
b' of
                Just ([[ℝ]]
bs, Int
bOuter, Int
_bInner) ->
                    if forall (t :: * -> *) a. Foldable t => t a -> Int
P.length [OVal]
a forall a. Ord a => a -> a -> Bool
>= Int
bOuter
                    then
                        forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                            (Text -> OVal
OError Text
"First vector of * is not a list of numbers.")
                            (\[ℝ]
a' -> [OVal] -> OVal
OList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ℝ -> OVal
ONum forall a b. (a -> b) -> a -> b
$ [ℝ]
a' forall a (t :: * -> *) (f :: * -> *).
(Num a, Foldable t, Additive f, Additive t) =>
t a -> t (f a) -> f a
*! [[ℝ]]
bs)
                            forall a b. (a -> b) -> a -> b
$ [OVal] -> Maybe [ℝ]
toNumList [OVal]
a
                    else Text -> OVal
OError Text
"First vector of * is too short to multiply with the matrix."
                Maybe ([[ℝ]], Int, Int)
_ -> Text -> OVal
OError Text
"Second matrix of * has rows that are too short."
            -- vector dot product
            (Maybe [[OVal]], Maybe [[OVal]])
_ -> OVal
dot
            where
                aList :: Maybe [[OVal]]
aList = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr OVal -> Maybe [[OVal]] -> Maybe [[OVal]]
f (forall (f :: * -> *) a. Applicative f => a -> f a
pure []) [OVal]
a
                bList :: Maybe [[OVal]]
bList = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr OVal -> Maybe [[OVal]] -> Maybe [[OVal]]
f (forall (f :: * -> *) a. Applicative f => a -> f a
pure []) [OVal]
b
                f :: OVal -> Maybe [[OVal]] -> Maybe [[OVal]]
                f :: OVal -> Maybe [[OVal]] -> Maybe [[OVal]]
f (OList [OVal]
x) (Just [[OVal]]
l) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [OVal]
x forall a. a -> [a] -> [a]
: [[OVal]]
l
                f OVal
_ Maybe [[OVal]]
_ = forall a. Maybe a
Nothing
                dot :: OVal
dot = [OVal] -> OVal
OList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith OVal -> OVal -> OVal
mult [OVal]
a [OVal]
b
        mult OVal
a         OVal
b         = Text -> OVal -> OVal -> OVal
errorAsAppropriate Text
"product" OVal
a OVal
b

        divide :: OVal
divide = (OVal -> OVal) -> OVal
OFunc forall a b. (a -> b) -> a -> b
$ \case
            (ONum ℝ
a) -> (OVal -> OVal) -> OVal
OFunc forall a b. (a -> b) -> a -> b
$ \case
                (ONum ℝ
b) -> ℝ -> OVal
ONum (forall a. Ord a => (a, a) -> a -> a
clamp (ℝ
minimumValue, ℝ
maximumValue) forall a b. (a -> b) -> a -> b
$ ℝ
aforall a. Fractional a => a -> a -> a
/ℝ
b)
                OVal
b        -> Text -> OVal -> OVal -> OVal
errorAsAppropriate Text
"divide" (ℝ -> OVal
ONum ℝ
a) OVal
b
            OVal
a -> (OVal -> OVal) -> OVal
OFunc forall a b. (a -> b) -> a -> b
$ \case
                OVal
b -> OVal -> OVal -> OVal
div' OVal
a OVal
b

        div' :: OVal -> OVal -> OVal
div' (ONum ℝ
a)  (ONum ℝ
b) = ℝ -> OVal
ONum  (forall a. Ord a => (a, a) -> a -> a
clamp (ℝ
minimumValue, ℝ
maximumValue) forall a b. (a -> b) -> a -> b
$  ℝ
aforall a. Fractional a => a -> a -> a
/ℝ
b)
        div' (OList [OVal]
a) (ONum ℝ
b) = [OVal] -> OVal
OList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\OVal
x -> OVal -> OVal -> OVal
div' OVal
x (ℝ -> OVal
ONum ℝ
b)) [OVal]
a)
        div' OVal
a         OVal
b        = Text -> OVal -> OVal -> OVal
errorAsAppropriate Text
"divide" OVal
a OVal
b

        omod :: OVal -> OVal -> OVal
omod (ONum ℝ
a) (ONum ℝ
b) = ℝ -> OVal
ONum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger forall a b. (a -> b) -> a -> b
$ forall a. Integral a => a -> a -> a
mod (forall a b. (RealFrac a, Integral b) => a -> b
floor ℝ
a) (forall a b. (RealFrac a, Integral b) => a -> b
floor ℝ
b)
        omod OVal
a        OVal
b        = Text -> OVal -> OVal -> OVal
errorAsAppropriate Text
"mod" OVal
a OVal
b

        concatenate :: OVal
concatenate = (OVal -> OVal) -> OVal
OFunc forall a b. (a -> b) -> a -> b
$ \case
            (OList (OVal
y:[OVal]
ys)) -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl OVal -> OVal -> OVal
append OVal
y [OVal]
ys
            (OList [])     -> [OVal] -> OVal
OList []
            OVal
_              -> Text -> OVal
OError Text
"concat takes a list"

        append :: OVal -> OVal -> OVal
append (OList   [OVal]
a) (OList   [OVal]
b) = [OVal] -> OVal
OList   forall a b. (a -> b) -> a -> b
$ [OVal]
aforall a. Semigroup a => a -> a -> a
<>[OVal]
b
        append (OString Text
a) (OString Text
b) = Text -> OVal
OString forall a b. (a -> b) -> a -> b
$ Text
aforall a. Semigroup a => a -> a -> a
<>Text
b
        append OVal
a           OVal
b           = Text -> OVal -> OVal -> OVal
errorAsAppropriate Text
"concat" OVal
a OVal
b

        sumtotal :: OVal
sumtotal = (OVal -> OVal) -> OVal
OFunc forall a b. (a -> b) -> a -> b
$ \case
            (OList (OVal
y:[OVal]
ys)) -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl OVal -> OVal -> OVal
add OVal
y [OVal]
ys
            (OList [])     -> ℝ -> OVal
ONum ℝ
0
            (ONum ℝ
a)       -> (OVal -> OVal) -> OVal
OFunc forall a b. (a -> b) -> a -> b
$ \case
                (OList []) -> ℝ -> OVal
ONum ℝ
a
                (OList [OVal]
n)  -> OVal -> OVal -> OVal
add (ℝ -> OVal
ONum ℝ
a) ([OVal] -> OVal
OList [OVal]
n)
                (ONum ℝ
b)   -> OVal -> OVal -> OVal
add (ℝ -> OVal
ONum ℝ
a) (ℝ -> OVal
ONum ℝ
b)
                OVal
_          -> Text -> OVal
OError Text
"sum takes two lists or nums"
            OVal
_              -> Text -> OVal
OError Text
"sum takes two lists or nums"

        add :: OVal -> OVal -> OVal
add (ONum ℝ
a) (ONum ℝ
b) = ℝ -> OVal
ONum (ℝ
aforall a. Num a => a -> a -> a
+ℝ
b)
        add (ONum ℝ
a)  (OList [OVal]
b) = [OVal] -> OVal
OList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (OVal -> OVal -> OVal
add (ℝ -> OVal
ONum ℝ
a)) [OVal]
b)
        add (OList [OVal]
a) (ONum ℝ
b)  = [OVal] -> OVal
OList (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (OVal -> OVal -> OVal
add (ℝ -> OVal
ONum ℝ
b)) [OVal]
a)
        add (OList [OVal]
a) (OList [OVal]
b) = [OVal] -> OVal
OList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith OVal -> OVal -> OVal
add [OVal]
a [OVal]
b
        add OVal
a OVal
b = Text -> OVal -> OVal -> OVal
errorAsAppropriate Text
"add" OVal
a OVal
b

        sub :: OVal -> OVal -> OVal
sub (ONum ℝ
a) (ONum ℝ
b) = ℝ -> OVal
ONum (ℝ
aforall a. Num a => a -> a -> a
-ℝ
b)
        sub (OList [OVal]
a) (OList [OVal]
b) = [OVal] -> OVal
OList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith OVal -> OVal -> OVal
sub [OVal]
a [OVal]
b
        sub OVal
a OVal
b = Text -> OVal -> OVal -> OVal
errorAsAppropriate Text
"subtract" OVal
a OVal
b

        negatefun :: OVal -> OVal
negatefun (ONum ℝ
n) = ℝ -> OVal
ONum (-ℝ
n)
        negatefun (OList [OVal]
l) = [OVal] -> OVal
OList forall a b. (a -> b) -> a -> b
$ OVal -> OVal
negatefun forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OVal]
l
        negatefun OVal
a = Text -> OVal
OError forall a b. (a -> b) -> a -> b
$ Text
"Can't negate " forall a. Semigroup a => a -> a -> a
<> OVal -> Text
oTypeStr OVal
a forall a. Semigroup a => a -> a -> a
<> Text
"(" forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show OVal
a) forall a. Semigroup a => a -> a -> a
<> Text
")"

        index :: OVal -> OVal -> OVal
index (OList [OVal]
l) (ONum ℝ
ind) =
            let
                n :: ℕ
                n :: ℕ
n = forall a b. (RealFrac a, Integral b) => a -> b
floor ℝ
ind
            in
              if ℕ
n forall a. Ord a => a -> a -> Bool
< forall i a. Num i => [a] -> i
genericLength [OVal]
l then [OVal]
l forall i a. Integral i => [a] -> i -> a
`genericIndex` ℕ
n else Text -> OVal
OError Text
"List accessed out of bounds"
        index (OString Text
s) (ONum ℝ
ind) =
            let
                n :: Int64
                n :: Int64
n = forall a b. (RealFrac a, Integral b) => a -> b
floor ℝ
ind
            in if Int64
n forall a. Ord a => a -> a -> Bool
< Text -> Int64
length Text
s then Text -> OVal
OString (Char -> Text
singleton (Text -> Int64 -> Char
TL.index Text
s Int64
n)) else Text -> OVal
OError Text
"List accessed out of bounds"
        -- For IO actions, get the OVal inside the IO and try to index that, rewrapping the results.
        index (OIO IO OVal
o) OVal
ind = IO OVal -> OVal
OIO forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip OVal -> OVal -> OVal
index OVal
ind forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO OVal
o

        index OVal
a OVal
b = Text -> OVal -> OVal -> OVal
errorAsAppropriate Text
"index" OVal
a OVal
b

        osplice :: OVal -> OVal -> OVal -> OVal
osplice (OList  [OVal]
list) (ONum ℝ
a) (    ONum ℝ
b    ) =
            [OVal] -> OVal
OList   forall a b. (a -> b) -> a -> b
$ forall a. [a] -> ℕ -> ℕ -> [a]
splice [OVal]
list (forall a b. (RealFrac a, Integral b) => a -> b
floor ℝ
a) (forall a b. (RealFrac a, Integral b) => a -> b
floor ℝ
b)
        osplice (OString Text
str) (ONum ℝ
a) (    ONum ℝ
b    ) =
            Text -> OVal
OString forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. [a] -> ℕ -> ℕ -> [a]
splice (Text -> String
unpack Text
str)  (forall a b. (RealFrac a, Integral b) => a -> b
floor ℝ
a) (forall a b. (RealFrac a, Integral b) => a -> b
floor ℝ
b)
        osplice (OList  [OVal]
list)  OVal
OUndefined  (ONum ℝ
b    ) =
            [OVal] -> OVal
OList   forall a b. (a -> b) -> a -> b
$ forall a. [a] -> ℕ -> ℕ -> [a]
splice [OVal]
list ℕ
0 (forall a b. (RealFrac a, Integral b) => a -> b
floor ℝ
b)
        osplice (OString Text
str)  OVal
OUndefined  (ONum ℝ
b    ) =
            Text -> OVal
OString forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. [a] -> ℕ -> ℕ -> [a]
splice (Text -> String
unpack Text
str)  ℕ
0 (forall a b. (RealFrac a, Integral b) => a -> b
floor ℝ
b)
        osplice (OList  [OVal]
list) (ONum ℝ
a)      OVal
OUndefined  =
            [OVal] -> OVal
OList   forall a b. (a -> b) -> a -> b
$ forall a. [a] -> ℕ -> ℕ -> [a]
splice [OVal]
list (forall a b. (RealFrac a, Integral b) => a -> b
floor ℝ
a) (forall i a. Num i => [a] -> i
genericLength [OVal]
list forall a. Num a => a -> a -> a
+ ℕ
1)
        osplice (OString Text
str) (ONum ℝ
a)      OVal
OUndefined  =
            Text -> OVal
OString forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. [a] -> ℕ -> ℕ -> [a]
splice (Text -> String
unpack Text
str)  (forall a b. (RealFrac a, Integral b) => a -> b
floor ℝ
a) (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Text -> Int64
length Text
str  forall a. Num a => a -> a -> a
+ Int64
1)
        osplice (OList  [OVal]
list)  OVal
OUndefined   OVal
OUndefined  =
            [OVal] -> OVal
OList   forall a b. (a -> b) -> a -> b
$ forall a. [a] -> ℕ -> ℕ -> [a]
splice [OVal]
list ℕ
0 (forall i a. Num i => [a] -> i
genericLength [OVal]
list forall a. Num a => a -> a -> a
+ ℕ
1)
        osplice (OString Text
str)  OVal
OUndefined   OVal
OUndefined =
            Text -> OVal
OString forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. [a] -> ℕ -> ℕ -> [a]
splice (Text -> String
unpack Text
str)  ℕ
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Text -> Int64
length Text
str  forall a. Num a => a -> a -> a
+ Int64
1)
        osplice OVal
_ OVal
_ OVal
_ = OVal
OUndefined

        splice :: [a] -> ℕ -> ℕ -> [a]
        splice :: forall a. [a] -> ℕ -> ℕ -> [a]
splice [] ℕ
_ ℕ
_     = []
        splice l :: [a]
l@(a
x:[a]
xs) ℕ
a ℕ
b
            |    ℕ
a forall a. Ord a => a -> a -> Bool
< ℕ
0  =    forall a. [a] -> ℕ -> ℕ -> [a]
splice [a]
l   (ℕ
aforall a. Num a => a -> a -> a
+ℕ
n)  ℕ
b
            |    ℕ
b forall a. Ord a => a -> a -> Bool
< ℕ
0  =    forall a. [a] -> ℕ -> ℕ -> [a]
splice [a]
l    ℕ
a    (ℕ
bforall a. Num a => a -> a -> a
+ℕ
n)
            |    ℕ
a forall a. Ord a => a -> a -> Bool
> ℕ
0  =    forall a. [a] -> ℕ -> ℕ -> [a]
splice [a]
xs  (ℕ
aforall a. Num a => a -> a -> a
-ℕ
1) (ℕ
bforall a. Num a => a -> a -> a
-ℕ
1)
            |    ℕ
b forall a. Ord a => a -> a -> Bool
> ℕ
0  = a
xforall a. a -> [a] -> [a]
: forall a. [a] -> ℕ -> ℕ -> [a]
splice [a]
xs   ℕ
a    (ℕ
bforall a. Num a => a -> a -> a
-ℕ
1)
            | Bool
otherwise = []
                    where
                      n :: ℕ
                      n :: ℕ
n = forall i a. Num i => [a] -> i
genericLength [a]
l

        errorAsAppropriate :: Text -> OVal -> OVal -> OVal
errorAsAppropriate Text
_   err :: OVal
err@(OError Text
_)   OVal
_ = OVal
err
        errorAsAppropriate Text
_   OVal
_   err :: OVal
err@(OError Text
_) = OVal
err
        errorAsAppropriate Text
name OVal
a OVal
b = Text -> OVal
OError forall a b. (a -> b) -> a -> b
$
          Text
"Can't " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" objects of types " forall a. Semigroup a => a -> a -> a
<> OVal -> Text
oTypeStr OVal
a forall a. Semigroup a => a -> a -> a
<> Text
" and " forall a. Semigroup a => a -> a -> a
<> OVal -> Text
oTypeStr OVal
b forall a. Semigroup a => a -> a -> a
<> Text
"."

        list_gen :: [ℝ] -> Maybe [ℝ]
        list_gen :: [ℝ] -> Maybe [ℝ]
list_gen [ℝ
a, ℝ
b] = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(forall a b. (RealFrac a, Integral b) => a -> b
ceiling ℝ
a).. (forall a b. (RealFrac a, Integral b) => a -> b
floor ℝ
b)]
        list_gen [ℝ
a, ℝ
b, ℝ
c] =
            let
                nr :: ℝ
nr = (ℝ
cforall a. Num a => a -> a -> a
-ℝ
a)forall a. Fractional a => a -> a -> a
/ℝ
b
                n :: ℝ
                n :: ℝ
n  = forall a. Num a => Integer -> a
fromInteger (forall a b. (RealFrac a, Integral b) => a -> b
floor ℝ
nr)
            in if ℝ
nr forall a. Num a => a -> a -> a
- ℝ
n forall a. Ord a => a -> a -> Bool
> ℝ
0
            then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(forall a b. (RealFrac a, Integral b) => a -> b
ceiling ℝ
a), (forall a b. (RealFrac a, Integral b) => a -> b
ceiling (ℝ
aforall a. Num a => a -> a -> a
+ℝ
b)).. (forall a b. (RealFrac a, Integral b) => a -> b
floor (ℝ
c forall a. Num a => a -> a -> a
- ℝ
bforall a. Num a => a -> a -> a
*(ℝ
nr forall a. Num a => a -> a -> a
-ℝ
n)))]
            else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(forall a b. (RealFrac a, Integral b) => a -> b
ceiling ℝ
a), (forall a b. (RealFrac a, Integral b) => a -> b
ceiling (ℝ
aforall a. Num a => a -> a -> a
+ℝ
b)).. (forall a b. (RealFrac a, Integral b) => a -> b
floor ℝ
c)]
        list_gen [ℝ]
_ = forall a. Maybe a
Nothing

        ternary :: Bool -> t -> t -> t
        ternary :: forall t. Bool -> t -> t -> t
ternary Bool
True t
a t
_ = t
a
        ternary Bool
False t
_ t
b = t
b

        olength :: OVal -> OVal
olength (OString Text
s) = ℝ -> OVal
ONum forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Text -> Int64
length Text
s
        olength (OList [OVal]
s)   = ℝ -> OVal
ONum forall a b. (a -> b) -> a -> b
$ forall i a. Num i => [a] -> i
genericLength [OVal]
s
        olength OVal
a           = Text -> OVal
OError forall a b. (a -> b) -> a -> b
$ Text
"Can't take length of a " forall a. Semigroup a => a -> a -> a
<> OVal -> Text
oTypeStr OVal
a forall a. Semigroup a => a -> a -> a
<> Text
"."