{-# LANGUAGE NoImplicitPrelude #-}
module Prelude
( module Prelude
, module Builtins
) where
import Builtins
infixr 9 .
infixl 7 `PrimMulMatVec`, `PrimDot`
infixr 5 ++
infixr 3 ***
infixr 0 $
--infixl 0 &
const x y = x
otherwise = True
x & f = f x
($) = \f x -> f x
(.) = \f g x -> f (g x)
uncurry f (x, y) = f x y
(***) f g (x, y) = (f x, g y)
pi = 3.141592653589793
zip :: [a] -> [b] -> [(a,b)]
zip [] xs = []
zip xs [] = []
zip (a: as) (b: bs) = (a,b): zip as bs
unzip :: [(a,b)] -> ([a],[b])
unzip [] = ([],[])
unzip ((a,b):xs) = (a:as,b:bs)
where (as,bs) = unzip xs
filter pred [] = []
filter pred (x:xs) = case pred x of
True -> (x : filter pred xs)
False -> (filter pred xs)
--head :: [a] -> a
--head (a: _) = a
tail :: [a] -> [a]
tail (_: xs) = xs
pairs :: [a] -> [(a, a)]
pairs v = zip v (tail v)
foldl' f e [] = e
foldl' f e (x: xs) = foldl' f (f e x) xs
foldr1 f (x: xs) = foldr f x xs
split [] = ([], [])
split (x: xs) = (x: bs, as) where (as, bs) = split xs
mergeBy f (x:xs) (y:ys) = case f x y of
LT -> x: mergeBy f xs (y:ys)
_ -> y: mergeBy f (x:xs) ys
mergeBy f [] xs = xs
mergeBy f xs [] = xs
sortBy f [] = []
sortBy f [x] = [x]
sortBy f xs = uncurry (mergeBy f) ((sortBy f *** sortBy f) (split xs))
iterate :: (a -> a) -> a -> [a]
iterate f x = x : iterate f (f x)
fst (a, b) = a
snd (a, b) = b
False ||| x = x
True ||| x = True
infixr 2 |||
True &&& x = x
False &&& x = False
infixr 3 &&&
------------------------------------ Row polymorphism
-- todo: sorted field names (more efficient & easier to use)
{-
isKey _ [] = False
isKey s ((s', _): ss) = s == s' ||| isKey s ss
subList [] _ = []
subList ((s, t): xs) ys = if isKey s ys then subList xs ys else (s, t): subList xs ys
addList [] ys = ys
addList ((s, t): xs) ys = if isKey s ys then addList xs ys else (s, t): addList xs ys
findEq x [] = 'Unit
findEq (s, t) ((s', t'):xs) = if s == s' then 'T2 (t ~ t') (findEq (s, t) xs) else findEq (s, t) xs
sameEq [] _ = 'Unit
sameEq (x: xs) ys = 'T2 (findEq x ys) (sameEq xs ys)
defined [] = True
defined (x: xs) = defined xs
type family Split a b c
type instance Split (RecordC xs) (RecordC ys) z | defined xs &&& defined ys = T2 (sameEq xs ys) (z ~ RecordC (subList xs ys))
type instance Split (RecordC xs) z (RecordC ys) | defined xs &&& defined ys = T2 (sameEq xs ys) (z ~ RecordC (subList xs ys))
type instance Split z (RecordC xs) (RecordC ys) | defined xs &&& defined ys = T2 (sameEq xs ys) (z ~ RecordC (addList xs ys))
-- builtin
-- TODO
record :: [(String, Type)] -> Type
--record xs = RecordCons ({- TODO: sortBy fst-} xs)
-}
data RecItem = RecItem String Type
recItemType (RecItem _ t) = t
data RecordC (xs :: [RecItem])
= RecordCons (HList (map recItemType xs))
isKeyC _ _ [] = 'CEmpty ""
isKeyC s t (RecItem s' t': ss) = if s == s' then t ~ t' else isKeyC s t ss
fstTup = hlistConsCase _ (\a _ -> a)
sndTup = hlistConsCase _ (\_ a -> a)
-- todo: don't use unsafeCoerce
project :: forall a (xs :: [RecItem]) . forall (s :: String) -> isKeyC s a xs => RecordC xs -> a
project @a @('RecItem s' a': xs) s @_ (RecordCons ts) | s == s' = fstTup (unsafeCoerce @_ @(HList '(a : map recItemType xs)) ts)
project @a @('RecItem s' a': xs) s @_ (RecordCons ts) = project @a @xs s @(undefined @(CW (isKeyC s a xs))) (RecordCons (sndTup (unsafeCoerce @_ @(HList '(a : map recItemType xs)) ts)))
--------------------------------------- HTML colors
rgb r g b = V4 r g b 1.0
black = rgb 0.0 0.0 0.0
gray = rgb 0.5 0.5 0.5
silver = rgb 0.75 0.75 0.75
white = rgb 1.0 1.0 1.0
maroon = rgb 0.5 0.0 0.0
red = rgb 1.0 0.0 0.0
olive = rgb 0.5 0.5 0.0
yellow = rgb 1.0 1.0 0.0
green = rgb 0.0 0.5 0.0
lime = rgb 0.0 1.0 0.0
teal = rgb 0.0 0.5 0.5
aqua = rgb 0.0 1.0 1.0
navy = rgb 0.0 0.0 0.5
blue = rgb 0.0 0.0 1.0
purple = rgb 0.5 0.0 0.5
fuchsia = rgb 1.0 0.0 1.0
colorImage1 = ColorImage @1
colorImage2 = ColorImage @2
depthImage1 = DepthImage @1
v3FToV4F :: Vec 3 Float -> Vec 4 Float
v3FToV4F v = V4 v%x v%y v%z 1
------------
-- * WebGL 1
------------
-- angle and trigonometric
radians = PrimRadians
degrees = PrimDegrees
sin = PrimSin
cos = PrimCos
tan = PrimTan
sinh = PrimSinH
cosh = PrimCosH
tanh = PrimTanH
asin = PrimASin
asinh = PrimASinH
acos = PrimACos
acosh = PrimACosH
atan = PrimATan
atanh = PrimATanH
atan2 = PrimATan2
-- exponential functions
pow = PrimPow
exp = PrimExp
log = PrimLog
exp2 = PrimExp2
log2 = PrimLog2
sqrt = PrimSqrt
inversesqrt = PrimInvSqrt
-- common functions
abs = PrimAbs
sign = PrimSign
floor = PrimFloor
trunc = PrimTrunc
round = PrimRound
roundEven = PrimRoundEven
ceil = PrimCeil
fract = PrimFract
mod = PrimMod
min = PrimMin
max = PrimMax
modF = PrimModF
clamp = PrimClamp
clampS = PrimClampS
mix = PrimMix
mixS = PrimMixS
mixB = PrimMixB
step = PrimStep
stepS = PrimStepS
smoothstep = PrimSmoothStep
smoothstepS = PrimSmoothStepS
isNan = PrimIsNan
isInf = PrimIsInf
dFdx = PrimDFdx
dFdy = PrimDFdy
fWidth = PrimFWidth
noise1 = PrimNoise1
noise2 = PrimNoise2
noise3 = PrimNoise3
noise4 = PrimNoise4
-- geometric functions
length = PrimLength
distance = PrimDistance
dot = PrimDot
cross = PrimCross
normalize = PrimNormalize
faceforward = PrimFaceForward
reflect = PrimReflect
refract = PrimRefract
transpose = PrimTranspose
det = PrimDeterminant
inv = PrimInverse
outer = PrimOuterProduct
bAnd = PrimBAnd
bOr = PrimBOr
bXor = PrimBXor
bNot = PrimBNot
bAndS = PrimBAndS
bOrS = PrimBOrS
bXorS = PrimBXorS
shiftL = PrimBShiftL
shiftR = PrimBShiftR
shiftLS = PrimBShiftLS
shiftRS = PrimBShiftRS
floatBitsToInt = PrimFloatBitsToInt
floatBitsToWord = PrimFloatBitsToUInt
intBitsToFloat = PrimIntBitsToFloat
wordBitsToFloat = PrimUIntBitsToFloat
-- operators
infixl 7 *, /, %
infixl 6 +, -
infix 4 /=, <, <=, >=, >
infixr 3 &&
infixr 2 ||
infix 7 `dot` -- dot
infix 7 `cross` -- cross
infixr 7 *. -- mulmv
infixl 7 .* -- mulvm
infixl 7 .*. -- mulmm
-- arithemtic
a + b = PrimAdd a b
a - b = PrimSub a b
a * b = PrimMul a b
a / b = PrimDiv a b
a % b = PrimMod a b
neg a = PrimNeg a
-- comparison
--a == b = PrimEqual a b
a /= b = PrimNotEqual a b
a < b = PrimLessThan a b
a <= b = PrimLessThanEqual a b
a >= b = PrimGreaterThanEqual a b
a > b = PrimGreaterThan a b
-- logical
a && b = PrimAnd a b
a || b = PrimOr a b
xor = PrimXor
not a = PrimNot a
any a = PrimAny a
all a = PrimAll a
-- matrix functions
a .*. b = PrimMulMatMat a b
a *. b = PrimMulMatVec a b
a .* b = PrimMulVecMat a b
-- temp hack for vector <---> scalar operators
infixl 7 *!, /!, %!
infixl 6 +!, -!
-- arithemtic
a +! b = PrimAddS a b
a -! b = PrimSubS a b
a *! b = PrimMulS a b
a /! b = PrimDivS a b
a %! b = PrimModS a b
------------------
-- common matrices
------------------
-- | Perspective transformation matrix in row major order.
perspective :: Float -- ^ Near plane clipping distance (always positive).
-> Float -- ^ Far plane clipping distance (always positive).
-> Float -- ^ Field of view of the y axis, in radians.
-> Float -- ^ Aspect ratio, i.e. screen's width\/height.
-> Mat 4 4 Float
perspective n f fovy aspect =
M44F (V4 (2*n/(r-l)) 0 0 0)
(V4 0 (2*n/(t-b)) 0 0)
(V4 ((r+l)/(r-l)) ((t+b)/(t-b)) (-(f+n)/(f-n)) (-1))
(V4 0 0 (-2*f*n/(f-n)) 0)
where
t = n*tan(fovy/2)
b = -t
r = aspect*t
l = -r
rotMatrixZ a = M44F (V4 c s 0 0) (V4 (-s) c 0 0) (V4 0 0 1 0) (V4 0 0 0 1)
where
c = cos a
s = sin a
rotMatrixY a = M44F (V4 c 0 (-s) 0) (V4 0 1 0 0) (V4 s 0 c 0) (V4 0 0 0 1)
where
c = cos a
s = sin a
rotMatrixX a = M44F (V4 1 0 0 0) (V4 0 c s 0) (V4 0 (-s) c 0) (V4 0 0 0 1)
where
c = cos a
s = sin a
rotationEuler a b c = rotMatrixY a .*. rotMatrixX b .*. rotMatrixZ c
translateBefore4 :: Vec 3 Float -> Mat 4 4 Float
translateBefore4 v = M44F r1 r2 r3 r4
where
r1 = V4 1 0 0 0
r2 = V4 0 1 0 0
r3 = V4 0 0 1 0
r4 = V4 v%x v%y v%z 1
-- | Camera transformation matrix.
lookat :: Vec 3 Float -- ^ Camera position.
-> Vec 3 Float -- ^ Target position.
-> Vec 3 Float -- ^ Upward direction.
-> Mat 4 4 Float
lookat pos target up = r .*. translateBefore4 (neg pos)
where
ext0 a = V4 a%x a%y a%z 0
w = normalize $ pos - target
u = normalize $ up `cross` w
v = w `cross` u
r = transpose $ M44F (ext0 u) (ext0 v) (ext0 w) (V4 0 0 0 1)
scale t v = v * V4 t t t 1.0
fromTo :: Float -> Float -> [Float]
fromTo a b
| a > b = []
| otherwise = a: fromTo (a + 1) b
(!!) :: [a] -> Int -> a
(x : _) !! 0 = x
(_ : xs) !! n = xs !! (n-1)