-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
-- Released under the GNU GPL, see LICENSE

-- We'd like to parse openscad code, with some improvements, for backwards compatability.

module Graphics.Implicit.ExtOpenScad.Default where

import Graphics.Implicit.Definitions
import Graphics.Implicit.ExtOpenScad.Definitions
import Graphics.Implicit.ExtOpenScad.Util.OVal
import Graphics.Implicit.ExtOpenScad.Primitives
import Data.Map (Map, fromList)

defaultObjects :: VarLookup -- = Map String OVal
defaultObjects = fromList $ 
	defaultConstants
	++ defaultFunctions
	++ defaultFunctions2
	++ defaultFunctionsSpecial
	++ defaultModules
	++ defaultPolymorphicFunctions

-- Missing standard ones:
-- rand, lookup, 

defaultConstants = map (\(a,b) -> (a, toOObj (b::ℝ) ))
	[("pi", pi)]

defaultFunctions = map (\(a,b) -> (a, toOObj ( b :: ℝ -> ℝ)))
	[
		("sin",   sin),
		("cos",   cos),
		("tan",   tan),
		("asin",  asin),
		("acos",  acos),
		("atan",  atan),
		("sinh",  sinh),
		("cosh",  cosh),
		("tanh",  tanh),
		("abs",   abs),
		("sign",  signum),
		("floor", fromIntegral . floor ),
		("ceil",  fromIntegral . ceiling ),
		("round", fromIntegral . round ),
		("exp",   exp),
		("ln",    log),
		("log",   log),
		("sign",  signum),
		("sqrt",  sqrt)
	]

defaultFunctions2 = map (\(a,b) -> (a, toOObj (b :: ℝ -> ℝ -> ℝ) ))
	[
		("max", max),
		("min", min),
		("atan2", atan2),
		("pow", (**))
	]

defaultFunctionsSpecial = 
	[
		("map", toOObj $ flip $ 
			(map :: (OVal -> OVal) -> [OVal] -> [OVal] ) 
		)
		
	]


defaultModules =
	map (\(a,b) -> (a, OModule b)) primitives



-- more complicated ones:

defaultPolymorphicFunctions = 
	[ 
		("+", sum),
		("sum", sum),
		("*", prod),
		("prod", prod),
		("/", div),
		("-", toOObj sub), 
		("^", toOObj ((**) :: ℝ -> ℝ -> ℝ)), 
		("negate", toOObj negate),
		("index", toOObj index),
		("splice", toOObj osplice),
		("<", toOObj  ((<) :: ℝ -> ℝ -> Bool) ),
		(">", toOObj  ((>) :: ℝ -> ℝ -> Bool) ),
		(">=", toOObj ((>=) :: ℝ -> ℝ -> Bool) ),
		("<=", toOObj ((<=) :: ℝ -> ℝ -> Bool) ),
		("==", toOObj ((==) :: OVal -> OVal -> Bool) ),
		("!=", toOObj ((/=) :: OVal -> OVal -> Bool) ),
		("?", toOObj ( ternary :: Bool -> OVal -> OVal -> OVal) ),
		("&&", toOObj (&&) ),
		("||", toOObj (||) ),
		("!", toOObj not ),
		("list_gen", toOObj list_gen),
		("++", concat),
		("len", toOObj olength),
		("str", toOObj (show :: OVal -> String))
	] where

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

		prod = OFunc $ \x -> case x of
			(OList (x:xs)) -> foldl mult x xs
			(OList [])     -> ONum 1
			a              -> OError ["Product takes a list"]

		mult (ONum a)  (ONum b)  = ONum  (a*b)
		mult (ONum a)  (OList b) = OList (map (mult (ONum a)) b)
		mult (OList a) (ONum b)  = OList (map (mult (ONum b)) a)
		mult a         b         = errorAsAppropriate "multiply" a b

		div = OFunc $ \x -> case x of
			(ONum a) -> OFunc $ \y -> case y of
				(ONum b) -> ONum (a/b)
				b        -> errorAsAppropriate "divide" (ONum a) b
			a -> OFunc $ \y -> case y of
				b -> div' a b

		div' (ONum a)  (ONum b) = ONum  (a/b)
		div' (OList a) (ONum b) = OList (map (\x -> div' x (ONum b)) a)
		div' a         b        = errorAsAppropriate "divide" a b

		omod (ONum a) (ONum b) = ONum $ fromIntegral $ mod (floor a) (floor b)
		omod a        b        = errorAsAppropriate "modulo" a b

		append (OList   a) (OList   b) = OList   $ a++b
		append (OString a) (OString b) = OString $ a++b
		append a           b           = errorAsAppropriate "append" a b

		concat = OFunc $ \x -> case x of
			(OList (x:xs)) -> foldl append x xs
			(OList [])     -> OList []
			_              -> OError ["concat takes a list"]

		sum = OFunc $ \x -> case x of
			(OList (x:xs)) -> foldl add x xs
			(OList [])     -> ONum 0
			a              -> OError ["Product takes a list"]

		add (ONum a) (ONum b) = ONum (a+b)
		add (OList a) (OList b) = OList $ zipWith add a b
		add a b = errorAsAppropriate "add" a b

		sub (ONum a) (ONum b) = ONum (a-b)
		sub (OList a) (OList b) = OList $ zipWith sub a b
		sub a b = errorAsAppropriate "subtract" a b

		negate (ONum n) = ONum (-n)
		negate (OList l) = OList $ map negate l
		negate a = OError ["Can't negate " ++ oTypeStr a ++ "(" ++ show a ++ ")"]

		{-numCompareToExprCompare :: (ℝ -> ℝ -> Bool) -> Oval -> OVal -> Bool
		numCompareToExprCompare f a b =
			case (fromOObj a :: Maybe ℝ, fromOObj b :: Maybe ℝ) of
				(Just a, Just b) -> f a b
				_ -> False-}

		index (OList l) (ONum ind) = 
			let n = floor ind 
			in if n < length l then l !! n else OError ["List accessd out of bounds"]
		index (OString s) (ONum ind) = 
			let n = floor ind 
			in if n < length s then OString [s !! n] else OError ["List accessd out of bounds"]
		index a b = errorAsAppropriate "index" a b

		osplice (OList  list) (ONum a) (    ONum b    ) = 
			OList   $ splice list (floor a) (floor b)
		osplice (OString str) (ONum a) (    ONum b    ) = 
			OString $ splice str  (floor a) (floor b)
		osplice (OList  list) (OUndefined) (ONum b    ) = 
			OList   $ splice list 0 (floor b)
		osplice (OString str) (OUndefined) (ONum b    ) = 
			OString $ splice str  0 (floor b)
		osplice (OList  list) (ONum a) (    OUndefined) = 
			OList   $ splice list (floor a) (length list + 1)
		osplice (OString str) (ONum a) (    OUndefined) = 
			OString $ splice str  (floor a) (length str  + 1)
		osplice (OList  list) (OUndefined) (OUndefined) = 
			OList   $ splice list 0 (length list + 1)
		osplice (OString str) (OUndefined) (OUndefined) = 
			OString $ splice str  0 (length str  + 1)
		osplice _ _ _ = OUndefined

		splice :: [a] -> Int -> Int -> [a]
		splice [] _ _     = []
		splice (l@(x:xs)) a b 
			|    a < 0  =    splice l   (a+n)  b
			|    b < 0  =    splice l    a    (b+n)
			|    a > 0  =    splice xs  (a-1) (b-1)
			|    b > 0  = x:(splice xs   a    (b-1) )
			| otherwise = []
					where n = length l

		errorAsAppropriate _   err@(OError _)   _ = err
		errorAsAppropriate _   _   err@(OError _) = err
		errorAsAppropriate name a b = OError 
			["Can't " ++ name ++ " objects of types " ++ oTypeStr a ++ " and " ++ oTypeStr b ++ "."]

		list_gen :: [ℝ] -> Maybe [ℝ]
		list_gen [a,b] = Just [fromIntegral (ceiling a).. fromIntegral (floor b)]
		list_gen [a, b, c] =
			let
				nr = (c-a)/b
				n  = fromIntegral (floor nr)
			in if nr - n > 0
			then Just 
				[fromIntegral (ceiling a), fromIntegral (ceiling (a+b)).. fromIntegral (floor (c - b*(nr -n)))]
			else Just 
				[fromIntegral (ceiling a), fromIntegral (ceiling (a+b)).. fromIntegral (floor c)]
		list_gen _ = Nothing

		ternary True a b = a
		ternary False a b = b

		olegnth (OString s) = ONum $ fromIntegral $ length s
		olength (OList s)   = ONum $ fromIntegral $ length s
		olength a           = OError ["Can't take length of a " ++ oTypeStr a ++ "."]