{-# 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)